NHINVIMM ;SLC/MKB -- Immunizations extract
;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
;
; External References DBIA#
; ------------------- -----
; ^DIC(4 10090
; ^VA(200 10060
; DIC 2051
; DIQ 2056
; PXRHS03,^TMP("PXI",$J) 1239
; XUAF4 2171
;
; ------------ Get immunizations from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's immunizations
N NHITM,NHICNT,NM,IDT,X
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
S BEG=$G(BEG,1410101),END=$G(END,9999998),MAX=$G(MAX,999999),NHICNT=0
K ^TMP("PXI",$J) D IMMUN^PXRHS03(DFN)
;
; get one immunization
I $G(IFN) D Q
. N DONE S DONE=0
. S NM="" F S NM=$O(^TMP("PXI",$J,NM)) Q:NM="" D Q:DONE
.. S IDT=0 F S IDT=$O(^TMP("PXI",$J,NM,IDT)) Q:IDT<1 I $D(^(IDT,IFN)) D Q
... D EN1(.NHITM),XML(.NHITM)
... S DONE=1
. K ^TMP("PXI",$J)
;
; get all immunizations
S X=BEG,BEG=9999999-END-.000001,END=9999999-X I $L(END,".")<2 S END=END_".2359"
S NM="" F S NM=$O(^TMP("PXI",$J,NM)) Q:NM="" D
. S IDT=BEG F S IDT=$O(^TMP("PXI",$J,NM,IDT)) Q:IDT<1!(IDT>END) D
.. S IFN=0 F S IFN=$O(^TMP("PXI",$J,NM,IDT,IFN)) Q:IFN<1 D Q:NHICNT'<MAX
... K NHITM D EN1(.NHITM),XML(.NHITM)
... S NHICNT=NHICNT+1
K ^TMP("PXI",$J)
Q
;
EN1(IMM) ; -- return an immunization in IMM("attribute")=value
; Expects ^TMP("PXI",$J,NM,IDT,IFN) from IMMUN^PXRHS03
N X0,X1,CPT,DA,X,Y K IMM
S X0=$G(^TMP("PXI",$J,NM,IDT,IFN,0)),X1=$G(^(1)),X=$G(^("COM"))
S:$L(X) IMM("comment")=X
S IMM("id")=IFN,IMM("name")=$P(X0,U)
S IMM("administered")=+$P(X0,U,3)
S IMM("series")=$P(X0,U,5)
S IMM("reaction")=$P(X0,U,6)
S IMM("contraindicated")=+$P(X0,U,7)
S IMM("location")=$P(X1,U)
S X=$P(X1,U,3) I $L(X) D
. S Y=$$LKUP^XUAF4(X) ;ien
. I Y<1 S Y=+$O(^DIC(4,"B",X,0)) ;dupl -> get 1st
. S IMM("facility")=$$STA^XUAF4(Y)_U_X
I '$D(IMM("facility")) S IMM("facility")=$$FAC^NHINV
S X=$P(X0,U,9) S:'$L(X) X=$P(X0,U,8)
I $L(X) S IMM("provider")=+$O(^VA(200,"B",X,0))_U_X
;
S DA=+$$GET1^DIQ(9000010.11,IFN_",",.01,"I") Q:'DA
S X=+$$FIND1^DIC(811.1,,"QX",DA_";AUTTIMM(","B") I X>0 D
. S Y=$$GET1^DIQ(811.1,X_",",.02,"I") Q:Y<1
. 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,P,NAMES,TAG
D ADD("<immunization>") S NHINTOTL=$G(NHINTOTL)+1
S ATT="" F S ATT=$O(IMM(ATT)) Q:ATT="" D
. S X=$G(IMM(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^NHINV(X)_"' />" D ADD(Y) Q
. I $L(X)>1 D
.. S Y="<"_ATT_" "
.. F P=1:1 S TAG=$P("code^name^Z",U,P) Q:TAG="Z" I $L($P(X,U,P)) S Y=Y_TAG_"='"_$$ESC^NHINV($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</immunization>")
Q
;
ADD(X) ; -- Add a line @NHIN@(n)=X
S NHINI=$G(NHINI)+1
S @NHIN@(NHINI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNHINVIMM 2989 printed Oct 16, 2024@18:18 Page 2
NHINVIMM ;SLC/MKB -- Immunizations extract
+1 ;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
+2 ;
+3 ; External References DBIA#
+4 ; ------------------- -----
+5 ; ^DIC(4 10090
+6 ; ^VA(200 10060
+7 ; DIC 2051
+8 ; DIQ 2056
+9 ; PXRHS03,^TMP("PXI",$J) 1239
+10 ; XUAF4 2171
+11 ;
+12 ; ------------ Get immunizations from VistA ------------
+13 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's immunizations
+1 NEW NHITM,NHICNT,NM,IDT,X
+2 ;invalid patient
SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,9999998)
SET MAX=$GET(MAX,999999)
SET NHICNT=0
+4 KILL ^TMP("PXI",$JOB)
DO IMMUN^PXRHS03(DFN)
+5 ;
+6 ; get one immunization
+7 IF $GET(IFN)
Begin DoDot:1
+8 NEW DONE
SET DONE=0
+9 SET NM=""
FOR
SET NM=$ORDER(^TMP("PXI",$JOB,NM))
if NM=""
QUIT
Begin DoDot:2
+10 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("PXI",$JOB,NM,IDT))
if IDT<1
QUIT
IF $DATA(^(IDT,IFN))
Begin DoDot:3
+11 DO EN1(.NHITM)
DO XML(.NHITM)
+12 SET DONE=1
End DoDot:3
QUIT
End DoDot:2
if DONE
QUIT
+13 KILL ^TMP("PXI",$JOB)
End DoDot:1
QUIT
+14 ;
+15 ; get all immunizations
+16 SET X=BEG
SET BEG=9999999-END-.000001
SET END=9999999-X
IF $LENGTH(END,".")<2
SET END=END_".2359"
+17 SET NM=""
FOR
SET NM=$ORDER(^TMP("PXI",$JOB,NM))
if NM=""
QUIT
Begin DoDot:1
+18 SET IDT=BEG
FOR
SET IDT=$ORDER(^TMP("PXI",$JOB,NM,IDT))
if IDT<1!(IDT>END)
QUIT
Begin DoDot:2
+19 SET IFN=0
FOR
SET IFN=$ORDER(^TMP("PXI",$JOB,NM,IDT,IFN))
if IFN<1
QUIT
Begin DoDot:3
+20 KILL NHITM
DO EN1(.NHITM)
DO XML(.NHITM)
+21 SET NHICNT=NHICNT+1
End DoDot:3
if NHICNT'<MAX
QUIT
End DoDot:2
End DoDot:1
+22 KILL ^TMP("PXI",$JOB)
+23 QUIT
+24 ;
EN1(IMM) ; -- return an immunization in IMM("attribute")=value
+1 ; Expects ^TMP("PXI",$J,NM,IDT,IFN) from IMMUN^PXRHS03
+2 NEW X0,X1,CPT,DA,X,Y
KILL IMM
+3 SET X0=$GET(^TMP("PXI",$JOB,NM,IDT,IFN,0))
SET X1=$GET(^(1))
SET X=$GET(^("COM"))
+4 if $LENGTH(X)
SET IMM("comment")=X
+5 SET IMM("id")=IFN
SET IMM("name")=$PIECE(X0,U)
+6 SET IMM("administered")=+$PIECE(X0,U,3)
+7 SET IMM("series")=$PIECE(X0,U,5)
+8 SET IMM("reaction")=$PIECE(X0,U,6)
+9 SET IMM("contraindicated")=+$PIECE(X0,U,7)
+10 SET IMM("location")=$PIECE(X1,U)
+11 SET X=$PIECE(X1,U,3)
IF $LENGTH(X)
Begin DoDot:1
+12 ;ien
SET Y=$$LKUP^XUAF4(X)
+13 ;dupl -> get 1st
IF Y<1
SET Y=+$ORDER(^DIC(4,"B",X,0))
+14 SET IMM("facility")=$$STA^XUAF4(Y)_U_X
End DoDot:1
+15 IF '$DATA(IMM("facility"))
SET IMM("facility")=$$FAC^NHINV
+16 SET X=$PIECE(X0,U,9)
if '$LENGTH(X)
SET X=$PIECE(X0,U,8)
+17 IF $LENGTH(X)
SET IMM("provider")=+$ORDER(^VA(200,"B",X,0))_U_X
+18 ;
+19 SET DA=+$$GET1^DIQ(9000010.11,IFN_",",.01,"I")
if 'DA
QUIT
+20 SET X=+$$FIND1^DIC(811.1,,"QX",DA_";AUTTIMM(","B")
IF X>0
Begin DoDot:1
+21 SET Y=$$GET1^DIQ(811.1,X_",",.02,"I")
if Y<1
QUIT
+22 SET CPT=$GET(@(U_$PIECE(Y,";",2)_+Y_",0)"))
+23 SET IMM("cpt")=$PIECE(CPT,U,1,2)
End DoDot:1
+24 QUIT
+25 ;
+26 ; ------------ Return data to middle tier ------------
+27 ;
XML(IMM) ; -- Return immunizations as XML
+1 NEW ATT,X,Y,I,P,NAMES,TAG
+2 DO ADD("<immunization>")
SET NHINTOTL=$GET(NHINTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(IMM(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 SET X=$GET(IMM(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+5 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^NHINV(X)_"' />"
DO ADD(Y)
QUIT
+6 IF $LENGTH(X)>1
Begin DoDot:2
+7 SET Y="<"_ATT_" "
+8 FOR P=1:1
SET TAG=$PIECE("code^name^Z",U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET Y=Y_TAG_"='"_$$ESC^NHINV($PIECE(X,U,P))_"' "
+9 SET Y=Y_"/>"
DO ADD(Y)
End DoDot:2
End DoDot:1
+10 DO ADD("</immunization>")
+11 QUIT
+12 ;
ADD(X) ; -- Add a line @NHIN@(n)=X
+1 SET NHINI=$GET(NHINI)+1
+2 SET @NHIN@(NHINI)=X
+3 QUIT
