- VPRDPXAM ;SLC/MKB -- PCE V Exams ;8/2/11 15:29
- ;;1.0;VIRTUAL PATIENT RECORD;**1**;Sep 01, 2011;Build 38
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; External References DBIA#
- ; ------------------- -----
- ; ^AUPNVSIT 2028
- ; ^PXRMINDX 4290
- ; DILFD 2055
- ; PXPXRM 4250
- ; XUAF4 2171
- ;
- ; ------------ Get data from VistA ------------
- ;
- EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's exams
- S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
- S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
- N VPRIDT,VPRN,VPRITM,VPRCNT
- ;
- ; get one exam
- I $G(IFN) D Q
- . N ITM,DATE K ^TMP("VPRPX",$J)
- . S ITM=0 F S ITM=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM)) Q:ITM<1 D Q:$D(VPRITM)
- .. S DATE=0 F S DATE=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM,DATE)) Q:DATE<1 I $D(^(DATE,IFN)) D Q
- ... S VPRIDT=9999999-DATE,^TMP("VPRPX",$J,VPRIDT,IFN)=ITM_U_DATE
- ... D EN1(IFN,.VPRITM),XML(.VPRITM)
- ;
- ; get all exams
- D SORT(DFN,BEG,END) S VPRCNT=0
- S VPRIDT=0 F S VPRIDT=$O(^TMP("VPRPX",$J,VPRIDT)) Q:VPRIDT<1 D Q:VPRCNT'<MAX
- . S VPRN=0 F S VPRN=$O(^TMP("VPRPX",$J,VPRIDT,VPRN)) Q:VPRN<1 D Q:VPRCNT'<MAX
- .. K VPRITM D EN1(VPRN,.VPRITM) Q:'$D(VPRITM)
- .. D XML(.VPRITM) S VPRCNT=VPRCNT+1
- K ^TMP("VPRPX",$J)
- Q
- ;
- SORT(DFN,START,STOP) ; -- build ^TMP("VPRPX",$J,9999999-DATE,DA)=ITM^DATE in range
- ; from ^PXRMINDX(9000010.13,"PI",DFN,ITM,DATE,DA)
- N ITM,DATE,DA,IDT K ^TMP("VPRPX",$J)
- S ITM=0 F S ITM=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM)) Q:ITM<1 D
- . S DATE=0 F S DATE=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM,DATE)) Q:DATE<1 D
- .. Q:DATE<START Q:DATE>STOP S IDT=9999999-DATE
- .. S DA=0 F S DA=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM,DATE,DA)) Q:DA<1 S ^TMP("VPRPX",$J,IDT,DA)=ITM_U_DATE
- Q
- ;
- EN1(IEN,PCE) ; -- return an exam in PCE("attribute")=value
- ; from EN: expects ^TMP("VPRPX",$J,VPRIDT,IEN)=ITM^DATE
- N VPRF,TMP,VISIT,X0,FAC,LOC,X K PCE
- D VXAM^PXPXRM(IEN,.VPRF)
- S PCE("id")=IEN,X=$G(VPRF("VALUE"))
- S PCE("result")=$$EXTERNAL^DILFD(9000010.13,.04,,X)
- S TMP=$G(^TMP("VPRPX",$J,VPRIDT,IEN)),PCE("dateTime")=$P(TMP,U,2)
- S PCE("name")=$$EXTERNAL^DILFD(9000010.13,.01,,+TMP)
- S PCE("comment")=$G(VPRF("COMMENTS"))
- S VISIT=$G(VPRF("VISIT")),PCE("encounter")=VISIT
- S X0=$G(^AUPNVSIT(+VISIT,0))
- S FAC=+$P(X0,U,6),LOC=+$P(X0,U,22)
- S:FAC PCE("facility")=$$STA^XUAF4(FAC)_U_$P($$NS^XUAF4(FAC),U)
- S:'FAC PCE("facility")=$$FAC^VPRD(LOC)
- Q
- ;
- ; ------------ Return data to middle tier ------------
- ;
- XML(PCE) ; -- Return patient data as XML in @VPR@(n)
- ; as <element code='123' displayName='ABC' />
- N ATT,X,Y,I,ID
- D ADD("<exam>") S VPRTOTL=$G(VPRTOTL)+1
- S ATT="" F S ATT=$O(PCE(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
- . S X=$G(PCE(ATT)),Y="" Q:'$L(X)
- . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
- . S Y="<"_ATT_" code='"_$P(X,U)_"' name='"_$$ESC^VPRD($P(X,U,2))_"' />"
- D ADD("</exam>")
- Q
- ;
- ADD(X) ; Add a line @VPR@(n)=X
- S VPRI=$G(VPRI)+1
- S @VPR@(VPRI)=X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPXAM 3141 printed Feb 19, 2025@00:11:25 Page 2
- VPRDPXAM ;SLC/MKB -- PCE V Exams ;8/2/11 15:29
- +1 ;;1.0;VIRTUAL PATIENT RECORD;**1**;Sep 01, 2011;Build 38
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; External References DBIA#
- +5 ; ------------------- -----
- +6 ; ^AUPNVSIT 2028
- +7 ; ^PXRMINDX 4290
- +8 ; DILFD 2055
- +9 ; PXPXRM 4250
- +10 ; XUAF4 2171
- +11 ;
- +12 ; ------------ Get data from VistA ------------
- +13 ;
- EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's exams
- +1 ;invalid patient
- SET DFN=+$GET(DFN)
- if DFN<1
- QUIT
- +2 SET BEG=$GET(BEG,1410101)
- SET END=$GET(END,4141015)
- SET MAX=$GET(MAX,9999)
- +3 NEW VPRIDT,VPRN,VPRITM,VPRCNT
- +4 ;
- +5 ; get one exam
- +6 IF $GET(IFN)
- Begin DoDot:1
- +7 NEW ITM,DATE
- KILL ^TMP("VPRPX",$JOB)
- +8 SET ITM=0
- FOR
- SET ITM=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM))
- if ITM<1
- QUIT
- Begin DoDot:2
- +9 SET DATE=0
- FOR
- SET DATE=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM,DATE))
- if DATE<1
- QUIT
- IF $DATA(^(DATE,IFN))
- Begin DoDot:3
- +10 SET VPRIDT=9999999-DATE
- SET ^TMP("VPRPX",$JOB,VPRIDT,IFN)=ITM_U_DATE
- +11 DO EN1(IFN,.VPRITM)
- DO XML(.VPRITM)
- End DoDot:3
- QUIT
- End DoDot:2
- if $DATA(VPRITM)
- QUIT
- End DoDot:1
- QUIT
- +12 ;
- +13 ; get all exams
- +14 DO SORT(DFN,BEG,END)
- SET VPRCNT=0
- +15 SET VPRIDT=0
- FOR
- SET VPRIDT=$ORDER(^TMP("VPRPX",$JOB,VPRIDT))
- if VPRIDT<1
- QUIT
- Begin DoDot:1
- +16 SET VPRN=0
- FOR
- SET VPRN=$ORDER(^TMP("VPRPX",$JOB,VPRIDT,VPRN))
- if VPRN<1
- QUIT
- Begin DoDot:2
- +17 KILL VPRITM
- DO EN1(VPRN,.VPRITM)
- if '$DATA(VPRITM)
- QUIT
- +18 DO XML(.VPRITM)
- SET VPRCNT=VPRCNT+1
- End DoDot:2
- if VPRCNT'<MAX
- QUIT
- End DoDot:1
- if VPRCNT'<MAX
- QUIT
- +19 KILL ^TMP("VPRPX",$JOB)
- +20 QUIT
- +21 ;
- SORT(DFN,START,STOP) ; -- build ^TMP("VPRPX",$J,9999999-DATE,DA)=ITM^DATE in range
- +1 ; from ^PXRMINDX(9000010.13,"PI",DFN,ITM,DATE,DA)
- +2 NEW ITM,DATE,DA,IDT
- KILL ^TMP("VPRPX",$JOB)
- +3 SET ITM=0
- FOR
- SET ITM=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM))
- if ITM<1
- QUIT
- Begin DoDot:1
- +4 SET DATE=0
- FOR
- SET DATE=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM,DATE))
- if DATE<1
- QUIT
- Begin DoDot:2
- +5 if DATE<START
- QUIT
- if DATE>STOP
- QUIT
- SET IDT=9999999-DATE
- +6 SET DA=0
- FOR
- SET DA=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM,DATE,DA))
- if DA<1
- QUIT
- SET ^TMP("VPRPX",$JOB,IDT,DA)=ITM_U_DATE
- End DoDot:2
- End DoDot:1
- +7 QUIT
- +8 ;
- EN1(IEN,PCE) ; -- return an exam in PCE("attribute")=value
- +1 ; from EN: expects ^TMP("VPRPX",$J,VPRIDT,IEN)=ITM^DATE
- +2 NEW VPRF,TMP,VISIT,X0,FAC,LOC,X
- KILL PCE
- +3 DO VXAM^PXPXRM(IEN,.VPRF)
- +4 SET PCE("id")=IEN
- SET X=$GET(VPRF("VALUE"))
- +5 SET PCE("result")=$$EXTERNAL^DILFD(9000010.13,.04,,X)
- +6 SET TMP=$GET(^TMP("VPRPX",$JOB,VPRIDT,IEN))
- SET PCE("dateTime")=$PIECE(TMP,U,2)
- +7 SET PCE("name")=$$EXTERNAL^DILFD(9000010.13,.01,,+TMP)
- +8 SET PCE("comment")=$GET(VPRF("COMMENTS"))
- +9 SET VISIT=$GET(VPRF("VISIT"))
- SET PCE("encounter")=VISIT
- +10 SET X0=$GET(^AUPNVSIT(+VISIT,0))
- +11 SET FAC=+$PIECE(X0,U,6)
- SET LOC=+$PIECE(X0,U,22)
- +12 if FAC
- SET PCE("facility")=$$STA^XUAF4(FAC)_U_$PIECE($$NS^XUAF4(FAC),U)
- +13 if 'FAC
- SET PCE("facility")=$$FAC^VPRD(LOC)
- +14 QUIT
- +15 ;
- +16 ; ------------ Return data to middle tier ------------
- +17 ;
- XML(PCE) ; -- Return patient data as XML in @VPR@(n)
- +1 ; as <element code='123' displayName='ABC' />
- +2 NEW ATT,X,Y,I,ID
- +3 DO ADD("<exam>")
- SET VPRTOTL=$GET(VPRTOTL)+1
- +4 SET ATT=""
- FOR
- SET ATT=$ORDER(PCE(ATT))
- if ATT=""
- QUIT
- Begin DoDot:1
- +5 SET X=$GET(PCE(ATT))
- SET Y=""
- if '$LENGTH(X)
- QUIT
- +6 IF X'["^"
- SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
- QUIT
- +7 SET Y="<"_ATT_" code='"_$PIECE(X,U)_"' name='"_$$ESC^VPRD($PIECE(X,U,2))_"' />"
- End DoDot:1
- if $LENGTH(Y)
- DO ADD(Y)
- +8 DO ADD("</exam>")
- +9 QUIT
- +10 ;
- ADD(X) ; Add a line @VPR@(n)=X
- +1 SET VPRI=$GET(VPRI)+1
- +2 SET @VPR@(VPRI)=X
- +3 QUIT