C0CCDA1 ; GPL - CCDA GENERATED FILE ROUTINES ; 6/20/15 6:03pm
 ;;0.1;C0CCDA;nopatch;noreleasedate;
 ;Copyright 2015 George Lilly.  Licensed Apache 2
 ;
 Q
 ;
LOADEHEX ; bulk load file EHEX PATIENT
 ;
 N ZI S ZI=0
 F  S ZI=$O(^DPT(ZI)) Q:+ZI=0  D  ;
 . N ICN
 . S ICN=$$ICN(ZI)
 . Q:'ICN
 . N C0CFDA
 . S C0CFDA(11302001,"?+1,",.01)=ICN
 . S C0CFDA(11302001,"?+1,",.001)=ZI
 . D UPDIE(.C0CFDA)
 Q
 ;
ICN(DFN) ; return the ICN of patient DFN
 N ZICN,ICN1,ICN2
 S ICN1=$$GET1^DIQ(2,DFN,991.01)
 S ICN2=$$GET1^DIQ(2,DFN,991.02)
 I ICN1="" S ZICN=""
 E  S ZICN=ICN1_"V"_ICN2
 Q ZICN
 ;
LOADTMP ; bulk load the document metadata in XTMP
 N GN S GN=$NA(^XTMP("C0CDOCS")) ; repository location
 K @GN
 I $G(^XTMP("C0CDOCS",0))="" D  ; work area doesnt' exist
 . N X,Y
 . S X="T+999" ; a long time from now
 . D ^%DT ; covert to FM date format
 . S @GN@(0)=Y_"^"_$$NOW^XLFDT_"^C0C Document exchange work area"
 N EHEX S EHEX=$NA(^KBAFEHEX(11302001)) ; list of patients
 N ZI S ZI=0
 F  S ZI=$O(@EHEX@(ZI)) Q:'ZI  D  ;
 . N LOC S LOC=$NA(@GN@(ZI))
 . N GX ; FOR XML - NOT SAVED
 . D DOONE(ZI,"GX",.LOC)
 . W:+$G(DEBUG) !,LOC
 . N ZJ S ZJ=0
 . F  S ZJ=$O(@LOC@("documents",ZJ)) Q:'ZJ  D  ;
 . . N DOCID
 . . S DOCID=@LOC@("documents",ZJ,"document@docId")
 . . S @GN@("PAT",ZI,ZJ,DOCID)=""
 . . S @GN@("DOCID",DOCID,ZI,ZJ)=""
 Q
 ;
wsQD(OUT,FILTER) ; web service for queryDocuments service
 I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW
 M ^GPL("FILTER")=FILTER
 N FORMAT
 S FORMAT=$G(FILTER("format"))
 S:FORMAT="" FORMAT=$G(FILTER("FORMAT"))
 I FORMAT="" S FORMAT="json"
 I $G(OUT)="" S OUT=$NA(^TMP("C0CQD",$J)) K @OUT
 N ICN,ZDFN
 S ZDFN=$G(FILTER("dfn"))
 I 'ZDFN D  ;
 . S ICN=$G(FILTER("icn"))
 . S ZDFN=$$ICN2PAT(ICN)
 Q:'ZDFN
 N TMPXML,TMPARY,GN
 S GN=$NA(^XTMP("C0CDOCS",ZDFN))
 M TMPARY=@GN
 ;D DOONE(ZDFN,"TMPXML","TMPARY")
 I FORMAT="xml" D  Q  ;
 . S HTTPRSP("mime")="text/xml"
 . D ARY2XML("TMPXML","TMPARY")
 . M @OUT=TMPXML
 . D ADDCRLF^VPRJRUT(OUT)
 I FORMAT="soap" D  Q  ;
 . I ZDFN'=9999 Q  ; only this patient works for now
 . S HTTPRSP("mime")="text/xml"
 . D QDRSP^C0CCDAS1(OUT,"TMPARY")
 D  ;
 . S HTTPRSP("mime")="application/json"
 . N JSON,JERR
 . D ENCODE^VPRJSON("TMPARY","JSON","JERR")
 . M @OUT=JSON(1)
 ;
 Q
 ;
TESTRD ;
 N PRM
 S PRM("patientId")=11
 S PRM("docid")="b43a6a55-32ea-4fa7-9be4-5b54b61657b0"
 S DEBUG=1
 K G
 D wsRD(.G,.PRM)
 Q
 ;
TESTRD2 ; test SOAP delivery of RD
 N PRM
 S PRM("patientId")=9999
 S PRM("docid")="ccd8423e-61bf-4e27-bbbd-760beddba9be"
 S DEBUG=1
 K G
 D wsRD(.G,.PRM)
 Q
 ;
wsRD(OUT,FILTER) ; web service for retrieveDocument service
 I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW
 ; log in - replace this with real security l
 ;N U,DT
 ;S U="^"
 ;N DUZ
 ;S DUZ=77
 ;S DUZ(2)=1 ; institution
 ;S DUZ("AG")="E"
 ;
 I $G(FILTER("format"))="soap" D  Q  ;
 . S HTTPRSP("mime")="text/xml"
 . I $G(OUT)="" S OUT=$NA(^TMP("CCDAOUT",$J,"XML")) K @OUT
 . N DOCID
 . S DOCID=$G(FILTER("docid"))
 . Q:DOCID=""
 . N FNM,ZDFN
 . S ZDFN=$$OID2PAT(DOCID)
 . Q:ZDFN'=9999 ; only this patient for now
 . D RDRSP^C0CCDAS1(OUT,"ARY")
 S HTTPRSP("mime")="text/xml"
 I $G(OUT)="" S OUT=$NA(^TMP("CCDAOUT",$J,"XML")) K @OUT
 N DOCID
 S DOCID=$G(FILTER("docid"))
 ;D ^ZTER
 Q:DOCID=""
 N FNM,ZDFN
 S ZDFN=$$OID2PAT(DOCID)
 S FNM=$$FNAME(DOCID)
 ;D ^ZTER
 Q:FNM=""  
 Q:'ZDFN
 N ZDFN2,ZSELECT
 S ZDFN2=$P($P(FNM,"CCDA-100-",2),"-",1) ; dfn in filename
 S ZSELECT=$P($P(FNM,".xml",1),"-",4)
 I ZDFN2'=ZDFN Q  ; wrong patient
 N ZFILTER
 S ZFILTER("patientId")=ZDFN
 S ZFILTER("SELECT")=ZSELECT
 S ZFILTER("NOTES")="ALL"
 S ZFILTER("docId")=DOCID
 ;N PARM
 ;D PRSPARMS(.FILTER,.PARM) ; parse incoming parms and overlay on defaults
 N SEL S SEL=$$FILTERV^JJOHPPC0(.ZFILTER,ZDFN)
 Q:'SEL "no matching visits"
 D LOGARY^JJOHPPCU("ZFILTER") ; log the parm array
 N C0LOG S C0LOG=1
 D CCDARPC^JJOHPPC0(.OUT,ZDFN,.ZFILTER)
 S @OUT@(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/css/CDA.xslt""?>"
 D ADDCRLF^VPRJRUT(.OUT)
 K ^TMP("CCDA",$J)
 ;
 Q
 ;
FNAME(ZOID) ; extrinsic returns the filename from the oid
 N GN S GN=$NA(^XTMP("C0CDOCS"))
 N DFN,DOCNUM
 S DFN=$O(@GN@("DOCID",ZOID,""))
 Q:'DFN ""
 S DOCNUM=$O(@GN@("DOCID",ZOID,DFN,""))
 Q:'DOCNUM ""
 Q $G(@GN@(DFN,"documents",DOCNUM,"document@fileName"))
 ;
ICN2PAT(ICN) ; extrinsic return
 N GN S GN=$NA(^KBAFEHEX(11302001))
 Q $O(@GN@("B",ICN,""))
 ;
OID2PAT(ZOID) ; extrinsic returns the DFN from the oid
 N GN S GN=$NA(^XTMP("C0CDOCS"))
 N DFN,DOCNUM
 S DFN=$O(@GN@("DOCID",ZOID,""))
 Q:'DFN ""
 Q DFN
 ;
 ;sample from D GETS^DIQ(171.5001,"1,","**","IE","C0CFDA")
 ;
 ;C0CFDA(171.5001,"1,",.01,"E")="CCDA-100-1-20050701.xml"
 ;C0CFDA(171.5001,"1,",.01,"I")="CCDA-100-1-20050701.xml"
 ;C0CFDA(171.5001,"1,",.02,"E")="ZZ PATIENT,TEST ONE"
 ;C0CFDA(171.5001,"1,",.02,"I")=1
 ;C0CFDA(171.5001,"1,",.021,"E")=500000000
 ;C0CFDA(171.5001,"1,",.021,"I")=500000000
 ;C0CFDA(171.5001,"1,",.03,"E")="JUN 21, 2015"
 ;C0CFDA(171.5001,"1,",.03,"I")=3150621
 ;C0CFDA(171.5001,"1,",.04,"E")="JUL 05, 2005"
 ;C0CFDA(171.5001,"1,",.04,"I")=3050705
 ;C0CFDA(171.5001,"1,",.05,"E")="JUL 05, 2005"
 ;C0CFDA(171.5001,"1,",.05,"I")=3050705
 ;C0CFDA(171.5001,"1,",.06,"E")="HISTORICAL SUMMARY OF CARE OUTPATIENT JUL 01, 2005"
 ;C0CFDA(171.5001,"1,",.06,"I")="HISTORICAL SUMMARY OF CARE OUTPATIENT JUL 01, 2005"
 ;C0CFDA(171.5001,"1,",.09,"E")=""
 ;C0CFDA(171.5001,"1,",.099,"E")=""
 ;C0CFDA(171.5001,"1,",.099,"I")=""
 ;C0CFDA(171.5001,"1,",1,"E")="HISTORICAL SUMMARY OF CARE"
 ;C0CFDA(171.5001,"1,",1,"I")=2
 ;C0CFDA(171.5001,"1,",1.1,"E")="xml"
 ;C0CFDA(171.5001,"1,",1.1,"I")=1
 ;C0CFDA(171.5001,"1,",1.2,"E")="HL7 CCDA MU2"
 ;C0CFDA(171.5001,"1,",1.2,"I")=1
 ;C0CFDA(171.5001,"1,",8,"E")=""
 ;C0CFDA(171.5001,"1,",8,"I")=""
 ;C0CFDA(171.5001,"1,",9,"E")=""
 ;C0CFDA(171.5001,"1,",9,"I")=""
 ;C0CFDA(171.50015,"1,1,",.01,"E")="SELECT"
 ;C0CFDA(171.50015,"1,1,",.01,"I")="SELECT"
 ;C0CFDA(171.50015,"1,1,",.02,"E")=20050701
 ;C0CFDA(171.50015,"1,1,",.02,"I")=20050701
 ;C0CFDA(171.50015,"2,1,",.01,"E")="NOTES"
 ;C0CFDA(171.50015,"2,1,",.01,"I")="NOTES"
 ;C0CFDA(171.50015,"2,1,",.02,"E")="ALL"
 ;C0CFDA(171.50015,"2,1,",.02,"I")="ALL"
 ;C0CFDA(171.50015,"3,1,",.01,"E")="FORMAT"
 ;C0CFDA(171.50015,"3,1,",.01,"I")="FORMAT"
 ;C0CFDA(171.50015,"3,1,",.02,"E")="XML"
 ;C0CFDA(171.50015,"3,1,",.02,"I")="XML"
 ;C0CFDA(171.5101,"1,1,",.01,"E")="JUN 21, 2015"
 ;C0CFDA(171.5101,"1,1,",.01,"I")=3150621
 ;C0CFDA(171.5101,"1,1,",.02,"E")=""
 ;C0CFDA(171.5101,"1,1,",.02,"I")=""
 ;
ADDONE(IARY) ; add one record to C0C GENERATED DOCUMENTS
 ;
 Q
 ;
ANALYZE ;
 ;
 Q
 ;
DOONE(DFN,OXML,OARY) ;
 ;
 I '$D(OXML) S OXML=$NA(^TMP("C0CCDA0",$J,"RXML"))
 I '$D(OARY) S OARY=$NA(^TMP("C0CCDA0",$J,"RARY"))
 K @OXML,@OARY
 N ARY
 D GETPAT^JJOHPPCE(.ARY,DFN,"visit")
 Q:'$D(ARY)
 N ROUT,ROU
 N COUNT S COUNT=$G(ARY("results","visits@total"))
 N OUTCNT S OUTCNT=0
 N C0CI,C0CDTS
 I COUNT>0 F C0CI=1:1:COUNT D  ;
 . N VRY,C0CDT,C0CFDT,C0CNM
 . I COUNT>1 M VRY=ARY("results","visits",C0CI,"visit")
 . E  M VRY=ARY("results","visits","visit")
 . S C0CFDT=$G(VRY("dateTime@value"))
 . S C0CDT=$TR($$FMTE^XLFDT(C0CFDT,"7DZ"),"/")
 . Q:'C0CDT
 . I $D(C0CDTS(C0CDT)) Q  ; already have this date
 . S OUTCNT=OUTCNT+1
 . S ROU=$NA(ROUT("documents",OUTCNT))
 . S C0CDTS(C0CDT)=""
 . S C0CNM="CCDA-100-"_DFN_"-"_C0CDT_".xml"
 . S @ROU@("document@docId")=$$UUID^C0CUTIL
 . S @ROU@("document@fileName")=C0CNM
 . S @ROU@("document@date")=$$FMTE^XLFDT(C0CFDT,"D")
 . S @ROU@("document@icn")=$$ICN(DFN)
 . S @ROU@("document@dfn")=DFN
 . S @ROU@("document@homeCommunityId")=$$ORGOID()
 . S @ROU@("document@loinc")="34133-9"
 . S @ROU@("document@loincText")="Continuity of Care Document"
 S ROUT("documents@count")=OUTCNT
 ;ZWR ROUT
 ;B
 N RXML
 D ARY2XML("RXML","ROUT")
 M @OXML=RXML
 M @OARY=ROUT
 Q
 ;
FIXLOINC ; one time routine to add loinc codes to all documents
 N ZI S ZI=0
 N GN S GN=$NA(^XTMP("C0CDOCS"))
 F  S ZI=$O(@GN@(ZI)) Q:'ZI  D  ;
 . N ZJ S ZJ=0
 . F  S ZJ=$O(@GN@(ZI,"documents",ZJ)) Q:'ZJ  D  ;
 . . N ROU S ROU=$NA(@GN@(ZI,"documents",ZJ))
 . . W !,"ICN= ",@ROU@("document@icn")
 . . S @ROU@("document@loinc")="34133-9"
 . . S @ROU@("document@loincText")="Continuity of Care Document"
 Q
 ;
ONEOUT(ZBUF,ZTXT) ; ADDS A LINE TO ZBUF
 N ZI S ZI=$O(@ZBUF@(""),-1)+1
 S @ZBUF@(ZI)=ZTXT
 Q
 ;
PUSH(BUF,STR) ;
 D ONEOUT(BUF,STR)
 Q
 ;
POP(BUF) ; extrinsic returns the last element and then deletes it
 N NM,TX
 S NM=$O(@BUF@(""),-1)
 Q:NM="" NM
 S TX=@BUF@(NM)
 K @BUF@(NM)
 Q TX
 ;
ARY2XML(OUTXML,INARY,STK,CHILD) ; convert an array to xml
 I '$D(@OUTXML@(1)) S @OUTXML@(1)="<?xml version=""1.0"" encoding=""utf-8"" ?>"
 N II S II=""
 N DATTR S DATTR="" ; deffered attributes
 F  S II=$O(@INARY@(II),-1) Q:II=""  D  ;
 . N ATTR,TAG
 . S ATTR="" S TAG=""
 . I II["@" D  ;
 . . I TAG="" S TAG=$P(II,"@",1) S ATTR=$P(II,"@",2)_"="""_@INARY@(II)_""""
 . . W:$G(DEBUG) !,"TAG="_TAG_" ATTR="_ATTR
 . . ;I $O(@INARY@(II))["@" D  ;
 . . ;F  S II=$O(@INARY@(II),-1) Q:II=""  Q:$O(@INARY@(II),-1)'[(TAG_"@")  D  ;
 . . F  S II=$O(@INARY@(II),-1) Q:II=""  Q:II'[(TAG_"@")  D  ;
 . . . S ATTR=ATTR_" "_$P(II,"@",2)_"="""_@INARY@(II)_""""
 . . . W:$G(DEBUG) !,"ATTR= ",ATTR
 . . . W:$G(DEBUG) !,"II= ",II
 . . S II=$O(@INARY@(II)) ; reset to previous
 . . N ENDING S ENDING="/"
 . . I II["@" D  ;
 . . . I $O(@INARY@(II),-1)=TAG S DATTR=" "_ATTR Q  ; deffered attributes
 . . . I $D(@INARY@(TAG)) S ENDING=""
 . . . D ONEOUT(OUTXML,"<"_TAG_" "_ATTR_ENDING_">")
 . . . I ENDING="" D PUSH("STK","</"_TAG_">")
 . I II'["@" D  ;
 . . I +II=0 D  ;
 . . . D ONEOUT(OUTXML,"<"_II_DATTR_">")
 . . . S DATTR="" ; reinitialize after use
 . . . D PUSH("STK","</"_II_">")
 . I $D(@INARY@(II)) D ARY2XML(OUTXML,$NA(@INARY@(II)))
 I $D(STK) F  D ONEOUT(OUTXML,$$POP("STK")) Q:'$D(STK)
 Q
 ;
UPDIE(ZFDA,ZIEN) ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
 ; ZFDA IS PASSED BY REFERENCE
 ; ZIEN IS PASSED BY REFERENCE
 D:$G(DEBUG)
 . ZWRITE ZFDA
 . B
 K ZERR
 D CLEAN^DILF
 D UPDATE^DIE("K","ZFDA","ZIEN","ZERR")
 I '$G(TRUST) I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST,
 ; INVOKE THE ERROR TRAP IF TASKED
 ;. W "ERROR",!
 ;. ZWR ZERR
 ;. B
 K ZFDA
 Q
 ;
ORGOID() ; extrinsic which returns the Organization OID
 Q "2.16.840.1.113883.5.83" ; WORLDVISTA HL7 OID - 
 ; REPLACE WITH OID LOOKUP FROM INSTITUTION FILE
 ;