- 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 Feb 19, 2025@00:11:28 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