- EDPHIST ;SLC/MKB - Return results history as XML ; 9/1/22 9:27am
- ;;2.0;EMERGENCY DEPARTMENT;**20**;May 2, 2012;Build 7
- ;External reference ^ORX8 supported by DBIA 871
- ;
- LAB(XML,PARAM) ; -- Return results history for lab orders
- K XML D ADD("<results>")
- ;
- ; validate input parameters
- N DFN,LOG,IN,MAX
- S DFN=+$$VAL("patient") I DFN<1 D ERR(1) G LQ
- S LOG=+$O(^EDP(230,"APA",DFN,0)),IN=$P($G(^EDP(230,LOG,0)),U,8)
- S MAX=$$VAL("total")
- ;
- K ^TMP("LRRR",$J) D RR^LR7OR1(DFN)
- ;
- ; get results for tests in each order
- N EDPI,ORIFN,NAME,STS,START,EDPY,EDPTST,ORPK,SUB,IDT,SEQ,EDPX,X,ORUPCHUK
- S EDPI=0 F S EDPI=$O(PARAM("order",EDPI)) Q:EDPI<1 D
- . S ORIFN=+$G(PARAM("order",EDPI)) Q:ORIFN<1
- . S NAME=$P($$OI^ORX8(ORIFN),U,2) ;get order text if null?
- . S STS=$$GET1^DIQ(100,ORIFN_",",5,"I")
- . D EN^ORX8(ORIFN)
- . S START=ORUPCHUK("ORSTRT")
- . I 'START S START=ORUPCHUK("ORODT")
- . S EDPY="<order id="""_ORIFN_""" name="""_$$ESC(NAME)_""" ack="""_$$ACK(ORIFN)_""" statusId="""_STS_""" statusName="""_$$STATUS(STS,"L",ORIFN)_""" collectedTS="""_START_""">"
- . D ADD(EDPY) K EDPY,EDPTST
- . ; add order results from visit
- . S ORPK=$$PKGID^ORX8(ORIFN) I $L(ORPK,";")'>3 G L1 ;no results
- . S SUB=$P(ORPK,";",4),IDT=$P(ORPK,";",5)
- . D ADD("<visit>")
- . S SEQ=0 F S SEQ=$O(^TMP("LRRR",$J,DFN,SUB,IDT,SEQ)) Q:SEQ<1 D
- .. K EDPX S EDPX("id")=SUB_";"_IDT_";"_SEQ
- .. D TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ) ;parse into EDPX("att")=value
- .. D ADDA("item",.EDPX)
- .. S X=$G(EDPX("testID")) S:X EDPTST(X)=""
- . D ADD("</visit>")
- . ;
- . ; add prior results of all included tests [up to MAX# collections]
- . N CNT,DONE,MORE
- . D ADD("<history>") S (CNT,DONE)=0
- . F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 D Q:DONE
- .. S SEQ=0,MORE=0
- .. F S SEQ=$O(^TMP("LRRR",$J,DFN,SUB,IDT,SEQ)) Q:SEQ<1 S X=$G(^(SEQ)) D
- ... Q:'$D(EDPTST(+X)) ;not a matching test
- ... K EDPX S EDPX("id")="CH;"_IDT_";"_SEQ,MORE=1
- ... D TMP^EDPLAB(.EDPX,DFN,"CH",IDT,SEQ) ;parse into EDPX("att")=value
- ... D ADDA("item",.EDPX)
- .. S:MORE CNT=CNT+1 I $G(MAX),CNT'<MAX S DONE=1
- . D ADD("</history>")
- L1 . D ADD("</order>")
- ;
- LQ ; end
- D ADD("</results>")
- Q
- ;
- ACK(ORDER,RETDATE) ; -- Return [first] user that ack'd order
- ; INPUT
- ; ORDER - Order IEN
- ; RETDATE - (optional) 1 if ack date is to be returned, otherwise do not return ack date
- N IFN,X,Y,Y1 S Y="false",Y1=""
- S RETDATE=$G(RETDATE,"")
- S IFN=0 F S IFN=+$O(^ORA(102.4,"B",+$G(ORDER),IFN)) Q:IFN<1 D Q:Y'="false"
- . S X=$G(^ORA(102.4,IFN,0))
- . I $P(X,U,3) S X=+$P(X,U,2),Y=$$GET1^DIQ(200,X_",",1),Y1=$P(X,U,3) ;Y=initials, Y1=date/time
- I RETDATE Q Y_U_Y1
- Q Y
- ;
- MED(XML,PARAM) ; -- Return dose & lab history for med
- K XML D ADD("<results>")
- ;
- ; validate input parameters
- N DFN,ORD,ORIT,ORVP,ORIDT,ORIFN,EDPLST,EDPX
- S DFN=+$$VAL("patient") I DFN<1 D ERR(1) G MQ
- S ORD=+$$VAL("order") I ORD<1 D ERR(4) G MQ
- S ORIT=+$$OI^ORX8(ORD) I ORIT<1 D ERR(5) G MQ
- S ORVP=DFN_";DPT("
- ;
- ; search Pharmacy for history of medication
- S ORIDT=0 F S ORIDT=$O(^OR(100,"AOI",ORIT,ORVP,ORIDT)) Q:ORIDT<1 D
- . S ORIFN=0 F S ORIFN=$O(^OR(100,"AOI",ORIT,ORVP,ORIDT,ORIFN)) Q:ORIFN<1 I ORIFN'=ORD S EDPLST(ORIFN)=""
- K ^TMP("PS",$J) I $O(EDPLST(0)) D
- . D ADD("<meds>")
- . S ORIFN=0 F S ORIFN=$O(EDPLST(ORIFN)) Q:ORIFN<1 D
- .. K EDPX D OEL^EDPMED(.EDPX,DFN,ORIFN,ORIDT)
- .. D ADDA("med",.EDPX)
- . D ADD("</meds>") K ^TMP("PS",$J)
- ;
- ; search Lab for result history of TEST
- N DRUG,TEST K ^TMP("LRRR",$J)
- S DRUG=+$$VALUE^ORCSAVE2(ORIFN,"DRUG")
- S TEST=$$GET1^DIQ(50,DRUG_",",17.2,"I") I TEST<1 G MQ
- D RR^LR7OR1(DFN,,,,,TEST) I $D(^TMP("LRRR",$J)) D
- . N SUB,IDT,SEQ
- . D ADD("<labs>")
- . S SUB=$O(^TMP("LRRR",$J,DFN,"")) Q:SUB=""
- . S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 D
- .. S SEQ=0 F S SEQ=$O(^TMP("LRRR",$J,DFN,SUB,IDT,SEQ)) Q:SEQ<1 D
- ... K EDPX ;S EDPX("id")=SUB_";"_IDT_";"_SEQ ??
- ... D TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ) ;parse into EDPX("att")=value
- ... D ADDA("lab",.EDPX)
- . D ADD("</labs>") K ^TMP("LRRR",$J)
- ;
- ; search for Clinical Events on ORIT/TEST
- I $D(^EDP(234,"AL",DFN,ORIT,TEST)) D
- . D ADD("<events>")
- . N EDPDT,DA,X0,X1,X2,EDPV S EDPDT=0
- . F S EDPDT=$O(^EDP(234,"AL",DFN,ORIT,TEST,EDPDT)) Q:EDPDT<1 S DA=+$O(^(EDPDT,0)) D
- .. S X0=$G(^EDP(234,DA,0)),X1=$G(^(1)),X2=$G(^(2)) K EDPV
- .. S EDPV("eventTS")=+X0,EDPV("title")=X1,EDPV("text")=X2
- .. S X=+$P(X0,U,3),EDPV("userID")=X,EDPV("id")=DA
- .. S EDPV("userName")=$P($G(^VA(200,X,0)),U)
- .. D ADDA("event",.EDPV)
- . D ADD("</events>")
- ;
- MQ ;end
- D ADD("</results>")
- Q
- ;
- VAL(X) Q $G(PARAM(X,1))
- ;
- STATUS(STS,TYPE,ORDER) ; -- Return result status for ORDER status
- N Y,X
- S Y=""
- S STS=+$G(STS),TYPE=$E($$UP^XLFSTR($G(TYPE))),ORDER=+$G(ORDER)
- I STS=1 S Y="Order discontinued" D:ORDER ;look for reason
- . S X=$$GET1^DIQ(100,ORDER_",",65) S:'$L(X) X=$$GET1^DIQ(100,ORDER_",",64)
- . I $L(X) S Y=Y_" ("_X_")"
- I STS=2 S Y=$S(TYPE="R":"Report",1:"Results")_$S($$ACKD(ORDER):" acknowledged",1:" available")
- I STS=3 S Y="On hold"
- I STS=5 S Y="Order pending"
- I STS=6 S Y=$S(TYPE="L":"Specimen in lab",TYPE="R":"In Process",1:"Active")
- I STS=7 S Y="Order expired"
- I STS=8 S Y=$S(TYPE="R":"Exam scheduled",1:"Scheduled")
- I STS=9 S Y="Partial results available"
- I STS=10!(STS=11) S Y="Order not released"
- I STS=12 S Y="Order discontinued (changed)"
- I STS=13 S Y="Order cancelled"
- I STS=14 S Y="Order discontinued (lapsed)"
- I STS=15 S Y="Order renewed"
- Q Y
- ;
- ACKD(ORDER) ; -- Returns 1 or 0, if ORDER has been acknowledged
- N Y,X,IFN S Y=0
- S IFN=0 F S IFN=$O(^ORA(102.4,"B",+$G(ORDER),IFN)) Q:IFN<1 D Q:Y
- . S X=$G(^ORA(102.4,IFN,0)) I $P(X,U,3) S Y=1 Q
- Q Y
- ;
- RANGE(VAL,BEG,END,MAX) ; -- Return BEG,END,MAX
- S BEG=$G(VAL("start",1)),END=$G(VAL("stop",1)),MAX=$G(VAL("total",1))
- S:BEG BEG=$$HL7TFM^XLFDT(BEG)
- S:END END=$$HL7TFM^XLFDT(END)
- I BEG,END,END<BEG N X S X=BEG,BEG=END,END=X ;switch
- I END,$L(END,".")<2 S END=END_".24"
- Q
- ;
- ERR(X) ; -- return error message
- N MSG
- I X=1 S MSG="Missing or invalid patient identifier"
- I X=2 S MSG="Missing or invalid data type"
- I X=3 S MSG="Missing or invalid observation identifier"
- I X=4 S MSG="Missing or invalid order number"
- I X=5 S MSG="Missing or invalid orderable item"
- ; X=? S MSG="others"
- I X=99 S MSG="Unknown request"
- D XML^EDPX("<error msg='"_MSG_"' />")
- Q
- ;
- UES(X) ; -- unescape incoming XML
- ; bwf: 12/19/2011 commented following line due to SAC. Need to figure out why this is here.
- ;Q $ZCONVERT(X,"I","HTML")
- ;
- ESC(X) ; -- escape outgoing XML
- ; Q $ZCONVERT(X,"O","HTML") ; uncomment for fastest performance on Cache
- ;
- N I,Y,QOT S QOT=""""
- S Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"&"_$P(X,"&",I)
- S X=Y,Y=$P(X,"<") F I=2:1:$L(X,"<") S Y=Y_"<"_$P(X,"<",I)
- S X=Y,Y=$P(X,">") F I=2:1:$L(X,">") S Y=Y_">"_$P(X,">",I)
- S X=Y,Y=$P(X,"'") F I=2:1:$L(X,"'") S Y=Y_"'"_$P(X,"'",I)
- S X=Y,Y=$P(X,QOT) F I=2:1:$L(X,QOT) S Y=Y_"""_$P(X,QOT,I)
- Q Y
- ;
- ADD(X) ; Add a line to XML(n)
- S XML=$G(XML)+1
- S XML(XML)=X
- Q
- ;
- ADDA(TAG,ATT) ; Add ATTribute list to XML(n)
- ; as <TAG att1="a" att2="b"... />
- N NODE,X,MULT,N,I
- S NODE="<"_TAG_" ",N=0
- S X="" F S X=$O(ATT(X)) Q:X="" D
- . I X="text",$L($G(ATT(X))) S N=N+1,MULT(N)="<"_X_" xml:space=""preserve"">"_$$ESC(ATT(X))_"</"_X_">" Q
- . I $L($G(ATT(X))) S NODE=NODE_X_"="""_$$ESC(ATT(X))_""" " Q
- . S N=N+1,MULT(N)="<"_X_"s>"
- . S I=0 F S I=$O(ATT(X,I)) Q:I<1 D
- .. I $L($G(ATT(X,I))) S N=N+1,MULT(N)="<"_X_$S(X="text":" xml:space=""preserve"">",1:">")_$$ESC(ATT(X,I))_"</"_X_">" Q
- .. N SUB,TXT,Y S Y="<"_X_" ",(TXT,SUB)=""
- .. F S SUB=$O(ATT(X,I,SUB)) Q:SUB="" D
- ... I SUB="text",$L($G(ATT(X,I,SUB))) S TXT="<text xml:space=""preserve"">"_$$ESC(ATT(X,I,SUB))_"</text>" Q
- ... I $L($G(ATT(X,I,SUB))) S Y=Y_SUB_"="""_$$ESC(ATT(X,I,SUB))_""" "
- .. S N=N+1,MULT(N)=Y_$S($L(TXT):">",1:"/>")
- .. S:$L(TXT) N=N+1,MULT(N)=TXT,N=N+1,MULT(N)="</"_X_">"
- . S N=N+1,MULT(N)="</"_X_"s>"
- S NODE=NODE_$S(N:"",1:"/")_">" D ADD(NODE)
- I N D
- . S I=0 F S I=$O(MULT(I)) Q:I<1 S X=MULT(I) D ADD(X)
- . S X="</"_TAG_">" D ADD(X)
- Q
- ;
- ADDE(ELMT) ; Add ELeMenT list to XML(n)
- N X,NODE
- S X="" F S X=$O(ELMT(X)) Q:X="" D
- . S NODE="<"_X_">"_$$ESC(ELMT(X))_"</"_X_">"
- . D ADD(NODE)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPHIST 8401 printed Feb 18, 2025@23:18:21 Page 2
- EDPHIST ;SLC/MKB - Return results history as XML ; 9/1/22 9:27am
- +1 ;;2.0;EMERGENCY DEPARTMENT;**20**;May 2, 2012;Build 7
- +2 ;External reference ^ORX8 supported by DBIA 871
- +3 ;
- LAB(XML,PARAM) ; -- Return results history for lab orders
- +1 KILL XML
- DO ADD("<results>")
- +2 ;
- +3 ; validate input parameters
- +4 NEW DFN,LOG,IN,MAX
- +5 SET DFN=+$$VAL("patient")
- IF DFN<1
- DO ERR(1)
- GOTO LQ
- +6 SET LOG=+$ORDER(^EDP(230,"APA",DFN,0))
- SET IN=$PIECE($GET(^EDP(230,LOG,0)),U,8)
- +7 SET MAX=$$VAL("total")
- +8 ;
- +9 KILL ^TMP("LRRR",$JOB)
- DO RR^LR7OR1(DFN)
- +10 ;
- +11 ; get results for tests in each order
- +12 NEW EDPI,ORIFN,NAME,STS,START,EDPY,EDPTST,ORPK,SUB,IDT,SEQ,EDPX,X,ORUPCHUK
- +13 SET EDPI=0
- FOR
- SET EDPI=$ORDER(PARAM("order",EDPI))
- if EDPI<1
- QUIT
- Begin DoDot:1
- +14 SET ORIFN=+$GET(PARAM("order",EDPI))
- if ORIFN<1
- QUIT
- +15 ;get order text if null?
- SET NAME=$PIECE($$OI^ORX8(ORIFN),U,2)
- +16 SET STS=$$GET1^DIQ(100,ORIFN_",",5,"I")
- +17 DO EN^ORX8(ORIFN)
- +18 SET START=ORUPCHUK("ORSTRT")
- +19 IF 'START
- SET START=ORUPCHUK("ORODT")
- +20 SET EDPY="<order id="""_ORIFN_""" name="""_$$ESC(NAME)_""" ack="""_$$ACK(ORIFN)_""" statusId="""_STS_""" statusName="""_$$STATUS(STS,"L",ORIFN)_""" collectedTS="""_START_""">"
- +21 DO ADD(EDPY)
- KILL EDPY,EDPTST
- +22 ; add order results from visit
- +23 ;no results
- SET ORPK=$$PKGID^ORX8(ORIFN)
- IF $LENGTH(ORPK,";")'>3
- GOTO L1
- +24 SET SUB=$PIECE(ORPK,";",4)
- SET IDT=$PIECE(ORPK,";",5)
- +25 DO ADD("<visit>")
- +26 SET SEQ=0
- FOR
- SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT,SEQ))
- if SEQ<1
- QUIT
- Begin DoDot:2
- +27 KILL EDPX
- SET EDPX("id")=SUB_";"_IDT_";"_SEQ
- +28 ;parse into EDPX("att")=value
- DO TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ)
- +29 DO ADDA("item",.EDPX)
- +30 SET X=$GET(EDPX("testID"))
- if X
- SET EDPTST(X)=""
- End DoDot:2
- +31 DO ADD("</visit>")
- +32 ;
- +33 ; add prior results of all included tests [up to MAX# collections]
- +34 NEW CNT,DONE,MORE
- +35 DO ADD("<history>")
- SET (CNT,DONE)=0
- +36 FOR
- SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
- if IDT<1
- QUIT
- Begin DoDot:2
- +37 SET SEQ=0
- SET MORE=0
- +38 FOR
- SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT,SEQ))
- if SEQ<1
- QUIT
- SET X=$GET(^(SEQ))
- Begin DoDot:3
- +39 ;not a matching test
- if '$DATA(EDPTST(+X))
- QUIT
- +40 KILL EDPX
- SET EDPX("id")="CH;"_IDT_";"_SEQ
- SET MORE=1
- +41 ;parse into EDPX("att")=value
- DO TMP^EDPLAB(.EDPX,DFN,"CH",IDT,SEQ)
- +42 DO ADDA("item",.EDPX)
- End DoDot:3
- +43 if MORE
- SET CNT=CNT+1
- IF $GET(MAX)
- IF CNT'<MAX
- SET DONE=1
- End DoDot:2
- if DONE
- QUIT
- +44 DO ADD("</history>")
- L1 DO ADD("</order>")
- End DoDot:1
- +1 ;
- LQ ; end
- +1 DO ADD("</results>")
- +2 QUIT
- +3 ;
- ACK(ORDER,RETDATE) ; -- Return [first] user that ack'd order
- +1 ; INPUT
- +2 ; ORDER - Order IEN
- +3 ; RETDATE - (optional) 1 if ack date is to be returned, otherwise do not return ack date
- +4 NEW IFN,X,Y,Y1
- SET Y="false"
- SET Y1=""
- +5 SET RETDATE=$GET(RETDATE,"")
- +6 SET IFN=0
- FOR
- SET IFN=+$ORDER(^ORA(102.4,"B",+$GET(ORDER),IFN))
- if IFN<1
- QUIT
- Begin DoDot:1
- +7 SET X=$GET(^ORA(102.4,IFN,0))
- +8 ;Y=initials, Y1=date/time
- IF $PIECE(X,U,3)
- SET X=+$PIECE(X,U,2)
- SET Y=$$GET1^DIQ(200,X_",",1)
- SET Y1=$PIECE(X,U,3)
- End DoDot:1
- if Y'="false"
- QUIT
- +9 IF RETDATE
- QUIT Y_U_Y1
- +10 QUIT Y
- +11 ;
- MED(XML,PARAM) ; -- Return dose & lab history for med
- +1 KILL XML
- DO ADD("<results>")
- +2 ;
- +3 ; validate input parameters
- +4 NEW DFN,ORD,ORIT,ORVP,ORIDT,ORIFN,EDPLST,EDPX
- +5 SET DFN=+$$VAL("patient")
- IF DFN<1
- DO ERR(1)
- GOTO MQ
- +6 SET ORD=+$$VAL("order")
- IF ORD<1
- DO ERR(4)
- GOTO MQ
- +7 SET ORIT=+$$OI^ORX8(ORD)
- IF ORIT<1
- DO ERR(5)
- GOTO MQ
- +8 SET ORVP=DFN_";DPT("
- +9 ;
- +10 ; search Pharmacy for history of medication
- +11 SET ORIDT=0
- FOR
- SET ORIDT=$ORDER(^OR(100,"AOI",ORIT,ORVP,ORIDT))
- if ORIDT<1
- QUIT
- Begin DoDot:1
- +12 SET ORIFN=0
- FOR
- SET ORIFN=$ORDER(^OR(100,"AOI",ORIT,ORVP,ORIDT,ORIFN))
- if ORIFN<1
- QUIT
- IF ORIFN'=ORD
- SET EDPLST(ORIFN)=""
- End DoDot:1
- +13 KILL ^TMP("PS",$JOB)
- IF $ORDER(EDPLST(0))
- Begin DoDot:1
- +14 DO ADD("<meds>")
- +15 SET ORIFN=0
- FOR
- SET ORIFN=$ORDER(EDPLST(ORIFN))
- if ORIFN<1
- QUIT
- Begin DoDot:2
- +16 KILL EDPX
- DO OEL^EDPMED(.EDPX,DFN,ORIFN,ORIDT)
- +17 DO ADDA("med",.EDPX)
- End DoDot:2
- +18 DO ADD("</meds>")
- KILL ^TMP("PS",$JOB)
- End DoDot:1
- +19 ;
- +20 ; search Lab for result history of TEST
- +21 NEW DRUG,TEST
- KILL ^TMP("LRRR",$JOB)
- +22 SET DRUG=+$$VALUE^ORCSAVE2(ORIFN,"DRUG")
- +23 SET TEST=$$GET1^DIQ(50,DRUG_",",17.2,"I")
- IF TEST<1
- GOTO MQ
- +24 DO RR^LR7OR1(DFN,,,,,TEST)
- IF $DATA(^TMP("LRRR",$JOB))
- Begin DoDot:1
- +25 NEW SUB,IDT,SEQ
- +26 DO ADD("<labs>")
- +27 SET SUB=$ORDER(^TMP("LRRR",$JOB,DFN,""))
- if SUB=""
- QUIT
- +28 SET IDT=0
- FOR
- SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
- if IDT<1
- QUIT
- Begin DoDot:2
- +29 SET SEQ=0
- FOR
- SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT,SEQ))
- if SEQ<1
- QUIT
- Begin DoDot:3
- +30 ;S EDPX("id")=SUB_";"_IDT_";"_SEQ ??
- KILL EDPX
- +31 ;parse into EDPX("att")=value
- DO TMP^EDPLAB(.EDPX,DFN,SUB,IDT,SEQ)
- +32 DO ADDA("lab",.EDPX)
- End DoDot:3
- End DoDot:2
- +33 DO ADD("</labs>")
- KILL ^TMP("LRRR",$JOB)
- End DoDot:1
- +34 ;
- +35 ; search for Clinical Events on ORIT/TEST
- +36 IF $DATA(^EDP(234,"AL",DFN,ORIT,TEST))
- Begin DoDot:1
- +37 DO ADD("<events>")
- +38 NEW EDPDT,DA,X0,X1,X2,EDPV
- SET EDPDT=0
- +39 FOR
- SET EDPDT=$ORDER(^EDP(234,"AL",DFN,ORIT,TEST,EDPDT))
- if EDPDT<1
- QUIT
- SET DA=+$ORDER(^(EDPDT,0))
- Begin DoDot:2
- +40 SET X0=$GET(^EDP(234,DA,0))
- SET X1=$GET(^(1))
- SET X2=$GET(^(2))
- KILL EDPV
- +41 SET EDPV("eventTS")=+X0
- SET EDPV("title")=X1
- SET EDPV("text")=X2
- +42 SET X=+$PIECE(X0,U,3)
- SET EDPV("userID")=X
- SET EDPV("id")=DA
- +43 SET EDPV("userName")=$PIECE($GET(^VA(200,X,0)),U)
- +44 DO ADDA("event",.EDPV)
- End DoDot:2
- +45 DO ADD("</events>")
- End DoDot:1
- +46 ;
- MQ ;end
- +1 DO ADD("</results>")
- +2 QUIT
- +3 ;
- VAL(X) QUIT $GET(PARAM(X,1))
- +1 ;
- STATUS(STS,TYPE,ORDER) ; -- Return result status for ORDER status
- +1 NEW Y,X
- +2 SET Y=""
- +3 SET STS=+$GET(STS)
- SET TYPE=$EXTRACT($$UP^XLFSTR($GET(TYPE)))
- SET ORDER=+$GET(ORDER)
- +4 ;look for reason
- IF STS=1
- SET Y="Order discontinued"
- if ORDER
- Begin DoDot:1
- +5 SET X=$$GET1^DIQ(100,ORDER_",",65)
- if '$LENGTH(X)
- SET X=$$GET1^DIQ(100,ORDER_",",64)
- +6 IF $LENGTH(X)
- SET Y=Y_" ("_X_")"
- End DoDot:1
- +7 IF STS=2
- SET Y=$SELECT(TYPE="R":"Report",1:"Results")_$SELECT($$ACKD(ORDER):" acknowledged",1:" available")
- +8 IF STS=3
- SET Y="On hold"
- +9 IF STS=5
- SET Y="Order pending"
- +10 IF STS=6
- SET Y=$SELECT(TYPE="L":"Specimen in lab",TYPE="R":"In Process",1:"Active")
- +11 IF STS=7
- SET Y="Order expired"
- +12 IF STS=8
- SET Y=$SELECT(TYPE="R":"Exam scheduled",1:"Scheduled")
- +13 IF STS=9
- SET Y="Partial results available"
- +14 IF STS=10!(STS=11)
- SET Y="Order not released"
- +15 IF STS=12
- SET Y="Order discontinued (changed)"
- +16 IF STS=13
- SET Y="Order cancelled"
- +17 IF STS=14
- SET Y="Order discontinued (lapsed)"
- +18 IF STS=15
- SET Y="Order renewed"
- +19 QUIT Y
- +20 ;
- ACKD(ORDER) ; -- Returns 1 or 0, if ORDER has been acknowledged
- +1 NEW Y,X,IFN
- SET Y=0
- +2 SET IFN=0
- FOR
- SET IFN=$ORDER(^ORA(102.4,"B",+$GET(ORDER),IFN))
- if IFN<1
- QUIT
- Begin DoDot:1
- +3 SET X=$GET(^ORA(102.4,IFN,0))
- IF $PIECE(X,U,3)
- SET Y=1
- QUIT
- End DoDot:1
- if Y
- QUIT
- +4 QUIT Y
- +5 ;
- RANGE(VAL,BEG,END,MAX) ; -- Return BEG,END,MAX
- +1 SET BEG=$GET(VAL("start",1))
- SET END=$GET(VAL("stop",1))
- SET MAX=$GET(VAL("total",1))
- +2 if BEG
- SET BEG=$$HL7TFM^XLFDT(BEG)
- +3 if END
- SET END=$$HL7TFM^XLFDT(END)
- +4 ;switch
- IF BEG
- IF END
- IF END<BEG
- NEW X
- SET X=BEG
- SET BEG=END
- SET END=X
- +5 IF END
- IF $LENGTH(END,".")<2
- SET END=END_".24"
- +6 QUIT
- +7 ;
- ERR(X) ; -- return error message
- +1 NEW MSG
- +2 IF X=1
- SET MSG="Missing or invalid patient identifier"
- +3 IF X=2
- SET MSG="Missing or invalid data type"
- +4 IF X=3
- SET MSG="Missing or invalid observation identifier"
- +5 IF X=4
- SET MSG="Missing or invalid order number"
- +6 IF X=5
- SET MSG="Missing or invalid orderable item"
- +7 ; X=? S MSG="others"
- +8 IF X=99
- SET MSG="Unknown request"
- +9 DO XML^EDPX("<error msg='"_MSG_"' />")
- +10 QUIT
- +11 ;
- UES(X) ; -- unescape incoming XML
- +1 ; bwf: 12/19/2011 commented following line due to SAC. Need to figure out why this is here.
- +2 ;Q $ZCONVERT(X,"I","HTML")
- +3 ;
- ESC(X) ; -- escape outgoing XML
- +1 ; Q $ZCONVERT(X,"O","HTML") ; uncomment for fastest performance on Cache
- +2 ;
- +3 NEW I,Y,QOT
- SET QOT=""""
- +4 SET Y=$PIECE(X,"&")
- FOR I=2:1:$LENGTH(X,"&")
- SET Y=Y_"&"_$PIECE(X,"&",I)
- +5 SET X=Y
- SET Y=$PIECE(X,"<")
- FOR I=2:1:$LENGTH(X,"<")
- SET Y=Y_"<"_$PIECE(X,"<",I)
- +6 SET X=Y
- SET Y=$PIECE(X,">")
- FOR I=2:1:$LENGTH(X,">")
- SET Y=Y_">"_$PIECE(X,">",I)
- +7 SET X=Y
- SET Y=$PIECE(X,"'")
- FOR I=2:1:$LENGTH(X,"'")
- SET Y=Y_"'"_$PIECE(X,"'",I)
- +8 SET X=Y
- SET Y=$PIECE(X,QOT)
- FOR I=2:1:$LENGTH(X,QOT)
- SET Y=Y_"""_$PIECE(X,QOT,I)
- +9 QUIT Y
- +10 ;
- ADD(X) ; Add a line to XML(n)
- +1 SET XML=$GET(XML)+1
- +2 SET XML(XML)=X
- +3 QUIT
- +4 ;
- ADDA(TAG,ATT) ; Add ATTribute list to XML(n)
- +1 ; as <TAG att1="a" att2="b"... />
- +2 NEW NODE,X,MULT,N,I
- +3 SET NODE="<"_TAG_" "
- SET N=0
- +4 SET X=""
- FOR
- SET X=$ORDER(ATT(X))
- if X=""
- QUIT
- Begin DoDot:1
- +5 IF X="text"
- IF $LENGTH($GET(ATT(X)))
- SET N=N+1
- SET MULT(N)="<"_X_" xml:space=""preserve"">"_$$ESC(ATT(X))_"</"_X_">"
- QUIT
- +6 IF $LENGTH($GET(ATT(X)))
- SET NODE=NODE_X_"="""_$$ESC(ATT(X))_""" "
- QUIT
- +7 SET N=N+1
- SET MULT(N)="<"_X_"s>"
- +8 SET I=0
- FOR
- SET I=$ORDER(ATT(X,I))
- if I<1
- QUIT
- Begin DoDot:2
- +9 IF $LENGTH($GET(ATT(X,I)))
- SET N=N+1
- SET MULT(N)="<"_X_$SELECT(X="text":" xml:space=""preserve"">",1:">")_$$ESC(ATT(X,I))_"</"_X_">"
- QUIT
- +10 NEW SUB,TXT,Y
- SET Y="<"_X_" "
- SET (TXT,SUB)=""
- +11 FOR
- SET SUB=$ORDER(ATT(X,I,SUB))
- if SUB=""
- QUIT
- Begin DoDot:3
- +12 IF SUB="text"
- IF $LENGTH($GET(ATT(X,I,SUB)))
- SET TXT="<text xml:space=""preserve"">"_$$ESC(ATT(X,I,SUB))_"</text>"
- QUIT
- +13 IF $LENGTH($GET(ATT(X,I,SUB)))
- SET Y=Y_SUB_"="""_$$ESC(ATT(X,I,SUB))_""" "
- End DoDot:3
- +14 SET N=N+1
- SET MULT(N)=Y_$SELECT($LENGTH(TXT):">",1:"/>")
- +15 if $LENGTH(TXT)
- SET N=N+1
- SET MULT(N)=TXT
- SET N=N+1
- SET MULT(N)="</"_X_">"
- End DoDot:2
- +16 SET N=N+1
- SET MULT(N)="</"_X_"s>"
- End DoDot:1
- +17 SET NODE=NODE_$SELECT(N:"",1:"/")_">"
- DO ADD(NODE)
- +18 IF N
- Begin DoDot:1
- +19 SET I=0
- FOR
- SET I=$ORDER(MULT(I))
- if I<1
- QUIT
- SET X=MULT(I)
- DO ADD(X)
- +20 SET X="</"_TAG_">"
- DO ADD(X)
- End DoDot:1
- +21 QUIT
- +22 ;
- ADDE(ELMT) ; Add ELeMenT list to XML(n)
- +1 NEW X,NODE
- +2 SET X=""
- FOR
- SET X=$ORDER(ELMT(X))
- if X=""
- QUIT
- Begin DoDot:1
- +3 SET NODE="<"_X_">"_$$ESC(ELMT(X))_"</"_X_">"
- +4 DO ADD(NODE)
- End DoDot:1
- +5 QUIT