VPRDPXIM ;SLC/MKB -- Immunizations extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**2,4,5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^PXRMINDX 4290
; ^SC 10040
; ^VA(200 10060
; DILFD 2055
; DIQ 2056
; ICPTCOD 1995
; PXAPI 1894
; PXPXRM 4250
; XUAF4 2171
;
; ------------ Get immunizations from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's immunizations
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999),VPRCNT=0
N VPRIDT,VPRN,VPRITM,VPRCNT
;
; get one immunization
I $G(IFN) D Q
. N IMZ,DATE K ^TMP("VPRIMM",$J)
. S IMZ=0 F S IMZ=$O(^PXRMINDX(9000010.11,"PI",+$G(DFN),IMZ)) Q:IMZ<1 D Q:$D(VPRITM)
.. S DATE=0 F S DATE=$O(^PXRMINDX(9000010.11,"PI",+$G(DFN),IMZ,DATE)) Q:DATE<1 I $D(^(DATE,IFN)) D Q
... S VPRIDT=9999999-DATE,VPRN=IFN
... S ^TMP("VPRIMM",$J,VPRIDT,IFN)=IMZ_U_DATE ;SORT node
... D EN1(IFN,.VPRITM),XML(.VPRITM)
. K ^TMP("VPRIMM",$J),^TMP("PXKENC",$J)
;
; get all immunizations
D SORT(DFN,BEG,END) S VPRCNT=0
S VPRIDT=0 F S VPRIDT=$O(^TMP("VPRIMM",$J,VPRIDT)) Q:VPRIDT<1 D Q:VPRCNT'<MAX
. S VPRN=0 F S VPRN=$O(^TMP("VPRIMM",$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("VPRIMM",$J),^TMP("PXKENC",$J)
Q
;
SORT(DFN,START,STOP) ; -- build ^TMP("VPRIMM",$J,9999999-DATE,DA)=IMM^DATE in range
; from ^PXRMINDX(9000010.11,"PI",DFN,IMM,DATE,DA)
N IMZ,DATE,DA,IDT K ^TMP("VPRIMM",$J)
S IMZ=0 F S IMZ=$O(^PXRMINDX(9000010.11,"PI",+$G(DFN),IMZ)) Q:IMZ<1 D
. S DATE=0 F S DATE=$O(^PXRMINDX(9000010.11,"PI",+$G(DFN),IMZ,DATE)) Q:DATE<1 D
.. Q:DATE<START Q:DATE>STOP S IDT=9999999-DATE
.. S DA=0 F S DA=$O(^PXRMINDX(9000010.11,"PI",+$G(DFN),IMZ,DATE,DA)) Q:DA<1 S ^TMP("VPRIMM",$J,IDT,DA)=IMZ_U_DATE
Q
;
EN1(IEN,IMM) ; -- return an immunization in IMM("attribute")=value
; Expects ^TMP("VPRIMM",$J,VPRIDT,VPRN)=IMM^DATE from EN/SORT
N TMP,VPRM,VISIT,X0,FAC,LOC,X2,X12,X13,LOT,X,I K IMM
S TMP=$G(^TMP("VPRIMM",$J,VPRIDT,VPRN))
S IMM("id")=IEN,IMM("administered")=+$P(TMP,U,2)
D VIMM^PXPXRM(IEN,.VPRM)
S X=$G(VPRM("IMMUNIZATION")) I X S IMM("name")=$P(X,U,2)
E S IMM("name")=$$EXTERNAL^DILFD(9000010.11,.01,,+TMP)
S X=$G(VPRM("SERIES")),IMM("series")=$$EXTERNAL^DILFD(9000010.11,.04,,X)
S X=$G(VPRM("REACTION")),IMM("reaction")=$$EXTERNAL^DILFD(9000010.11,.06,,X)
S IMM("contraindicated")=+$G(VPRM("CONTRAINDICATED"))
S IMM("comment")=$G(VPRM("COMMENTS"))
S VISIT=+$G(VPRM("VISIT")),IMM("encounter")=VISIT
VST ; look for values added by PX*1*210
S X=$G(VPRM("LOCATION")) S:X IMM("location")=$P(X,U,2) I 'X D G LOT
. I '$D(^TMP("PXKENC",$J,VISIT)) D ENCEVENT^PXAPI(VISIT,1)
. S X0=$G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0))
. S FAC=+$P(X0,U,6),LOC=+$P(X0,U,22)
. S:FAC IMM("facility")=$$STA^XUAF4(FAC)_U_$P($$NS^XUAF4(FAC),U)
. S:'FAC IMM("facility")=$$FAC^VPRD(LOC)
. S IMM("location")=$P($G(^SC(LOC,0)),U)
. S X12=$G(^TMP("PXKENC",$J,VISIT,"IMM",IEN,12)),X13=$G(^(13))
. S X=$P(X12,U,4) ;S:'X X=$P(X12,U,2)
. I 'X S I=0 F S I=$O(^TMP("PXKENC",$J,VISIT,"PRV",I)) Q:I<1 I $P($G(^(I,0)),U,4)="P" S X=+^(0) Q
. S:X IMM("provider")=X_U_$P($G(^VA(200,X,0)),U)
S X=$G(VPRM("FACILITY")) S:X IMM("facility")=$P(X,U,3)_U_$P(X,U,2)
S X=$G(VPRM("ENCOUNTER PROVIDER")) S:X IMM("provider")=X
LOT ; lot number, information
S X=$G(VPRM("ORDERING PROVIDER")) S:X IMM("orderingProvider")=X
S X=$G(VPRM("DOCUMENTER")) S:X IMM("documentedBy")=X
S LOT=$G(VPRM("LOT NUMBER")) I LOT D ;Lot#
. S IMM("lot")=$P(LOT,U,2)
. S X=$G(VPRM("MANUFACTURER")) S:X IMM("manufacturer")=$P(X,U,2)
. S X=$G(VPRM("EXPIRATION DATE")) S:X IMM("expirationDate")=X
S X=$G(VPRM("INFO SOURCE")) S:X IMM("source")=$P(X,U,2,3)
S X=$G(VPRM("ADMIN ROUTE")) S:X IMM("route")=$P(X,U,2,3)
S X=$G(VPRM("ADMIN SITE")) S:X IMM("bodySite")=$P(X,U,2,3)
S X=$G(VPRM("DOSAGE")) I $L(X) S IMM("dose")=X
E D ;Dose field to be split
. S X=$G(VPRM("DOSE")) S:$L(X) IMM("dose")=X
. S X=$G(VPRM("DOSE UNITS")) S:$L(X) IMM("units")=X
VIS ; vaccine information sheet
S I=0 F S I=$O(VPRM("VIS OFFERED",I)) Q:I<1 D
. S X=$G(VPRM("VIS OFFERED",I,0)) ;ien^date^name^editionDate^language
. S IMM("vis",+I)=$P(X,U,2,5)
CVX ; CVX, CPT mappings
S X=$G(VPRM("CVX")) I $L(X) S IMM("cvx")=X
E S X=$$GET1^DIQ(9999999.14,+TMP_",",.03) S:$L(X) IMM("cvx")=X
S X=$G(VPRM("CODES","CPT")) I $L(X) D Q
. S X=$$CPT^ICPTCOD(X)
. S IMM("cpt")=$P(X,U,2,3)
; phase out codes from 811.1 ...
S X=+$$FIND1^DIC(811.1,,"QX",+TMP_";AUTTIMM(","B") I X>0 D
. S Y=$$GET1^DIQ(811.1,X_",",.02,"I") Q:Y<1
. N CPT S CPT=$G(@(U_$P(Y,";",2)_+Y_",0)"))
. S IMM("cpt")=$P(CPT,U,1,2)
Q
;
; ------------ Return data to middle tier ------------
;
XML(IMM) ; -- Return immunizations as XML
N ATT,X,Y,I,NAMES
D ADD("<immunization>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(IMM(ATT)) Q:ATT="" D
. S NAMES=$S(ATT="vis":"date^name^editionDate^language",1:"code^name")_"^Z"
. I ATT="vis" D Q
.. D ADD("<"_ATT_">")
.. S I="" F S I=$O(IMM(ATT,I)) Q:I="" D
... S X=$G(IMM(ATT,I)),Y="<sheet "_$$LOOP_"/>"
... D ADD(Y)
.. D ADD("</"_ATT_">")
. S X=$G(IMM(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" D ADD(Y) Q
. I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
D ADD("</immunization>")
Q
;
ADD(X) ; -- Add a line @VPR@(n)=X
S VPRI=$G(VPRI)+1
S @VPR@(VPRI)=X
Q
;
LOOP() ; -- build sub-items string from NAMES and X
N STR,P,TAG S STR=""
F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
Q STR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPXIM 6051 printed Apr 09, 2024@21:47:37 Page 2
VPRDPXIM ;SLC/MKB -- Immunizations extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,4,5**;Sep 01, 2011;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^PXRMINDX 4290
+7 ; ^SC 10040
+8 ; ^VA(200 10060
+9 ; DILFD 2055
+10 ; DIQ 2056
+11 ; ICPTCOD 1995
+12 ; PXAPI 1894
+13 ; PXPXRM 4250
+14 ; XUAF4 2171
+15 ;
+16 ; ------------ Get immunizations from VistA ------------
+17 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's immunizations
+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)
SET VPRCNT=0
+3 NEW VPRIDT,VPRN,VPRITM,VPRCNT
+4 ;
+5 ; get one immunization
+6 IF $GET(IFN)
Begin DoDot:1
+7 NEW IMZ,DATE
KILL ^TMP("VPRIMM",$JOB)
+8 SET IMZ=0
FOR
SET IMZ=$ORDER(^PXRMINDX(9000010.11,"PI",+$GET(DFN),IMZ))
if IMZ<1
QUIT
Begin DoDot:2
+9 SET DATE=0
FOR
SET DATE=$ORDER(^PXRMINDX(9000010.11,"PI",+$GET(DFN),IMZ,DATE))
if DATE<1
QUIT
IF $DATA(^(DATE,IFN))
Begin DoDot:3
+10 SET VPRIDT=9999999-DATE
SET VPRN=IFN
+11 ;SORT node
SET ^TMP("VPRIMM",$JOB,VPRIDT,IFN)=IMZ_U_DATE
+12 DO EN1(IFN,.VPRITM)
DO XML(.VPRITM)
End DoDot:3
QUIT
End DoDot:2
if $DATA(VPRITM)
QUIT
+13 KILL ^TMP("VPRIMM",$JOB),^TMP("PXKENC",$JOB)
End DoDot:1
QUIT
+14 ;
+15 ; get all immunizations
+16 DO SORT(DFN,BEG,END)
SET VPRCNT=0
+17 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("VPRIMM",$JOB,VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+18 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("VPRIMM",$JOB,VPRIDT,VPRN))
if VPRN<1
QUIT
Begin DoDot:2
+19 KILL VPRITM
DO EN1(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+20 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:2
if VPRCNT'<MAX
QUIT
End DoDot:1
if VPRCNT'<MAX
QUIT
+21 KILL ^TMP("VPRIMM",$JOB),^TMP("PXKENC",$JOB)
+22 QUIT
+23 ;
SORT(DFN,START,STOP) ; -- build ^TMP("VPRIMM",$J,9999999-DATE,DA)=IMM^DATE in range
+1 ; from ^PXRMINDX(9000010.11,"PI",DFN,IMM,DATE,DA)
+2 NEW IMZ,DATE,DA,IDT
KILL ^TMP("VPRIMM",$JOB)
+3 SET IMZ=0
FOR
SET IMZ=$ORDER(^PXRMINDX(9000010.11,"PI",+$GET(DFN),IMZ))
if IMZ<1
QUIT
Begin DoDot:1
+4 SET DATE=0
FOR
SET DATE=$ORDER(^PXRMINDX(9000010.11,"PI",+$GET(DFN),IMZ,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.11,"PI",+$GET(DFN),IMZ,DATE,DA))
if DA<1
QUIT
SET ^TMP("VPRIMM",$JOB,IDT,DA)=IMZ_U_DATE
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
EN1(IEN,IMM) ; -- return an immunization in IMM("attribute")=value
+1 ; Expects ^TMP("VPRIMM",$J,VPRIDT,VPRN)=IMM^DATE from EN/SORT
+2 NEW TMP,VPRM,VISIT,X0,FAC,LOC,X2,X12,X13,LOT,X,I
KILL IMM
+3 SET TMP=$GET(^TMP("VPRIMM",$JOB,VPRIDT,VPRN))
+4 SET IMM("id")=IEN
SET IMM("administered")=+$PIECE(TMP,U,2)
+5 DO VIMM^PXPXRM(IEN,.VPRM)
+6 SET X=$GET(VPRM("IMMUNIZATION"))
IF X
SET IMM("name")=$PIECE(X,U,2)
+7 IF '$TEST
SET IMM("name")=$$EXTERNAL^DILFD(9000010.11,.01,,+TMP)
+8 SET X=$GET(VPRM("SERIES"))
SET IMM("series")=$$EXTERNAL^DILFD(9000010.11,.04,,X)
+9 SET X=$GET(VPRM("REACTION"))
SET IMM("reaction")=$$EXTERNAL^DILFD(9000010.11,.06,,X)
+10 SET IMM("contraindicated")=+$GET(VPRM("CONTRAINDICATED"))
+11 SET IMM("comment")=$GET(VPRM("COMMENTS"))
+12 SET VISIT=+$GET(VPRM("VISIT"))
SET IMM("encounter")=VISIT
VST ; look for values added by PX*1*210
+1 SET X=$GET(VPRM("LOCATION"))
if X
SET IMM("location")=$PIECE(X,U,2)
IF 'X
Begin DoDot:1
+2 IF '$DATA(^TMP("PXKENC",$JOB,VISIT))
DO ENCEVENT^PXAPI(VISIT,1)
+3 SET X0=$GET(^TMP("PXKENC",$JOB,VISIT,"VST",VISIT,0))
+4 SET FAC=+$PIECE(X0,U,6)
SET LOC=+$PIECE(X0,U,22)
+5 if FAC
SET IMM("facility")=$$STA^XUAF4(FAC)_U_$PIECE($$NS^XUAF4(FAC),U)
+6 if 'FAC
SET IMM("facility")=$$FAC^VPRD(LOC)
+7 SET IMM("location")=$PIECE($GET(^SC(LOC,0)),U)
+8 SET X12=$GET(^TMP("PXKENC",$JOB,VISIT,"IMM",IEN,12))
SET X13=$GET(^(13))
+9 ;S:'X X=$P(X12,U,2)
SET X=$PIECE(X12,U,4)
+10 IF 'X
SET I=0
FOR
SET I=$ORDER(^TMP("PXKENC",$JOB,VISIT,"PRV",I))
if I<1
QUIT
IF $PIECE($GET(^(I,0)),U,4)="P"
SET X=+^(0)
QUIT
+11 if X
SET IMM("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)
End DoDot:1
GOTO LOT
+12 SET X=$GET(VPRM("FACILITY"))
if X
SET IMM("facility")=$PIECE(X,U,3)_U_$PIECE(X,U,2)
+13 SET X=$GET(VPRM("ENCOUNTER PROVIDER"))
if X
SET IMM("provider")=X
LOT ; lot number, information
+1 SET X=$GET(VPRM("ORDERING PROVIDER"))
if X
SET IMM("orderingProvider")=X
+2 SET X=$GET(VPRM("DOCUMENTER"))
if X
SET IMM("documentedBy")=X
+3 ;Lot#
SET LOT=$GET(VPRM("LOT NUMBER"))
IF LOT
Begin DoDot:1
+4 SET IMM("lot")=$PIECE(LOT,U,2)
+5 SET X=$GET(VPRM("MANUFACTURER"))
if X
SET IMM("manufacturer")=$PIECE(X,U,2)
+6 SET X=$GET(VPRM("EXPIRATION DATE"))
if X
SET IMM("expirationDate")=X
End DoDot:1
+7 SET X=$GET(VPRM("INFO SOURCE"))
if X
SET IMM("source")=$PIECE(X,U,2,3)
+8 SET X=$GET(VPRM("ADMIN ROUTE"))
if X
SET IMM("route")=$PIECE(X,U,2,3)
+9 SET X=$GET(VPRM("ADMIN SITE"))
if X
SET IMM("bodySite")=$PIECE(X,U,2,3)
+10 SET X=$GET(VPRM("DOSAGE"))
IF $LENGTH(X)
SET IMM("dose")=X
+11 ;Dose field to be split
IF '$TEST
Begin DoDot:1
+12 SET X=$GET(VPRM("DOSE"))
if $LENGTH(X)
SET IMM("dose")=X
+13 SET X=$GET(VPRM("DOSE UNITS"))
if $LENGTH(X)
SET IMM("units")=X
End DoDot:1
VIS ; vaccine information sheet
+1 SET I=0
FOR
SET I=$ORDER(VPRM("VIS OFFERED",I))
if I<1
QUIT
Begin DoDot:1
+2 ;ien^date^name^editionDate^language
SET X=$GET(VPRM("VIS OFFERED",I,0))
+3 SET IMM("vis",+I)=$PIECE(X,U,2,5)
End DoDot:1
CVX ; CVX, CPT mappings
+1 SET X=$GET(VPRM("CVX"))
IF $LENGTH(X)
SET IMM("cvx")=X
+2 IF '$TEST
SET X=$$GET1^DIQ(9999999.14,+TMP_",",.03)
if $LENGTH(X)
SET IMM("cvx")=X
+3 SET X=$GET(VPRM("CODES","CPT"))
IF $LENGTH(X)
Begin DoDot:1
+4 SET X=$$CPT^ICPTCOD(X)
+5 SET IMM("cpt")=$PIECE(X,U,2,3)
End DoDot:1
QUIT
+6 ; phase out codes from 811.1 ...
+7 SET X=+$$FIND1^DIC(811.1,,"QX",+TMP_";AUTTIMM(","B")
IF X>0
Begin DoDot:1
+8 SET Y=$$GET1^DIQ(811.1,X_",",.02,"I")
if Y<1
QUIT
+9 NEW CPT
SET CPT=$GET(@(U_$PIECE(Y,";",2)_+Y_",0)"))
+10 SET IMM("cpt")=$PIECE(CPT,U,1,2)
End DoDot:1
+11 QUIT
+12 ;
+13 ; ------------ Return data to middle tier ------------
+14 ;
XML(IMM) ; -- Return immunizations as XML
+1 NEW ATT,X,Y,I,NAMES
+2 DO ADD("<immunization>")
SET VPRTOTL=$GET(VPRTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(IMM(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 SET NAMES=$SELECT(ATT="vis":"date^name^editionDate^language",1:"code^name")_"^Z"
+5 IF ATT="vis"
Begin DoDot:2
+6 DO ADD("<"_ATT_">")
+7 SET I=""
FOR
SET I=$ORDER(IMM(ATT,I))
if I=""
QUIT
Begin DoDot:3
+8 SET X=$GET(IMM(ATT,I))
SET Y="<sheet "_$$LOOP_"/>"
+9 DO ADD(Y)
End DoDot:3
+10 DO ADD("</"_ATT_">")
End DoDot:2
QUIT
+11 SET X=$GET(IMM(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+12 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
DO ADD(Y)
QUIT
+13 IF $LENGTH(X)>1
SET Y="<"_ATT_" "_$$LOOP_"/>"
DO ADD(Y)
End DoDot:1
+14 DO ADD("</immunization>")
+15 QUIT
+16 ;
ADD(X) ; -- Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
+4 ;
LOOP() ; -- build sub-items string from NAMES and X
+1 NEW STR,P,TAG
SET STR=""
+2 FOR P=1:1
SET TAG=$PIECE(NAMES,U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
+3 QUIT STR
