VENPCCS2 ; IHS/OIT/GIS - POPULATE OCX IMMUNIZATIONS OBJECT AND MAIL MERGRE FIELDS ; 16 Nov 2007 10:04 AM
;;2.6;PCC+;;NOV 12, 2007
;
; SUPPORTS IMM PGK VER 7 AND HIGHER
; DEAD CODE IN 2.5
;
IMM(DFN) ; EP-GET IMMUNIZATION DATA AND RETURN IT IN A FORMATTED STRING
I '$D(^DPT(+$G(DFN),0)) Q ""
N STG1,STG2,X,TMP,STG
S TMP="^TMP(""VEN IMM"","_$J_")" K @TMP
S X=$T(IMMHX^BIRPC) I '$L(X) Q ""
S X=$T(IMMFORC^BIRPC) I '$L(X) Q ""
I $L($T(VER^BILOGO)),$$VER^BILOGO>7.99,$L($T(IMMBI^BIAPCHS)) S STG=$$NEWIMM(DFN) K @TMP Q STG ; ACCOMODATES NEW IMMINUZATION PKG
D IMMHX^BIRPC(.STG1,DFN)
D IMMFORC^BIRPC(.STG2,DFN)
ABORT I '$L(STG1),'$L(STG2) Q ""
STG D ANAL(STG1,STG2)
FMT S STG=$$FORMAT
K @TMP
I '$G(WFLG) D CLN
D FORC(STG) ; MAIL MERGE FORECASTING COMPONENT
Q STG
;
ANAL(STG1,STG2) ; EP-ANALYSIS OF THE HX AND FORCAST STRINGS
N B,PCE1,PCE2,X,Y,%DT,CPT,CPTIEN,ICLASS,IDATE,IIEN,ILOC,IMM,IR,IRNO,STG,STYPE,VIIEN
S B="|"
F PCE1=1:1:$L(STG1,U) S X=$P(STG1,U,PCE1) I X'="" D
. S ICLASS=$P(X,B,2) I '$L(ICLASS) Q
. S IMM=$P(X,B,6) I '$L(IMM) Q
. S VIIEN=+$P(X,B,4) I 'VIIEN Q
. S ILOC=$P(X,B,5)
. S STYPE=$P(X,B,6) I '$L(STYPE) S STYPE="OTHER"
. S IDATE=$P(X,B,7) I IDATE S IDATE=$E(IDATE,1,11),%DT="",X=IDATE D ^%DT
. I Y'?7N Q
. S IDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))
. S %=$G(^AUPNVIMM(VIIEN,0)) S IRNO=$P(%,U,6),IIEN=+% I 'IIEN Q
. S IR="" I IRNO S %=$P($G(^DD(9000010.11,.06,0)),U,3),%=";"_%,Y=$P(%,(";"_IRNO_":"),2),IR=$P(Y,";") I IR="OTHER" S IR="UNSPECIFIED REACTION"
. I $L(IR) S @TMP@("IR",ICLASS,IR)="" I $G(WFLG) Q
. S @TMP@("ORD",STYPE,2,ICLASS,PCE1)=IDATE_"_"_IMM_"_"_ILOC
. Q
K STG1
I $G(WFLG) Q ; WARNINGS ONLY
F PCE2=1:1:$L(STG2,U) S X=$P(STG2,U,PCE2) I X'="" D
. S IMM=$P(X,B,1) I '$L(IMM) Q
. S IMM=$$STRIP^VENPCCU(IMM)
. S DUE="Yes"
. S ICLASS=IMM I IMM?1N1"-"1.E S ICLASS=$P(IMM,"-",2,99)
. S CPT="",STYPE="OTHER",IIEN=$O(^AUTTIMM("D",ICLASS,0))
. I IIEN D
.. S STNO=+$P($G(^AUTTIMM(IIEN,0)),U,9),STYPE=$P($G(^BISERT(STNO,0)),U)
.. I STYPE="" S STYPE="OTHER"
.. S CPTIEN=+$P($G(^AUTTIMM(IIEN,0)),U,11),CPT=$P($G(^ICPT(CPTIEN,0)),U)
.. Q
. S @TMP@("ORD",STYPE,1,ICLASS,PCE2)=IMM_"~"_DUE_"~"_CPT_"~"
. Q
K STG2
S STYPE="" F S STYPE=$O(@TMP@("ORD",STYPE)) Q:STYPE="" S ICLASS="" F S ICLASS=$O(@TMP@("ORD",STYPE,2,ICLASS)) Q:ICLASS="" D
. I '$D(@TMP@("ORD",STYPE,1,ICLASS)) S @TMP@("ORD",STYPE,1,ICLASS,1)=ICLASS_"~No~~"
. Q
Q
;
FORMAT() ; EP-FORMAT THE OUTPUT STRINGS
N WARN,ORD,HX,IIEN,ICLASS,CNT,IIEN,IR,STYPE,CNT1,CNT2,ICLASS
S WARN="",IIEN=0
S ICLASS="",CNT=0
I $G(WFLG),$D(@TMP@("IR")) F S ICLASS=$O(@TMP@("IR",ICLASS)) Q:ICLASS="" S IR="" F S IR=$O(@TMP@("IR",ICLASS,IR)) Q:IR="" D
. I 'CNT S CNT=1 S WARN=WARN_$S($L(WARN):" ",1:"")_"Warnings: "_ICLASS_" CAUSES "_IR Q
. S WARN=WARN_", "_ICLASS_" CAUSES "_IR
. Q
I $G(WFLG) Q WARN ; WARNINGS ONLY
S STYPE="",ORD=""
F S STYPE=$O(@TMP@("ORD",STYPE)) Q:STYPE="" S ICLASS="" F S ICLASS=$O(@TMP@("ORD",STYPE,1,ICLASS)) Q:ICLASS="" D
. S CNT1=0 F S CNT1=$O(@TMP@("ORD",STYPE,1,ICLASS,CNT1)) Q:'CNT1 D
.. S ORD=ORD_@TMP@("ORD",STYPE,1,ICLASS,CNT1),CNT2=0,CNT=0
.. F S CNT2=$O(@TMP@("ORD",STYPE,2,ICLASS,CNT2)) Q:'CNT2 D
... I CNT S ORD=ORD_"`"
... E S CNT=1
... S ORD=ORD_@TMP@("ORD",STYPE,2,ICLASS,CNT2)
... Q
.. S ORD=ORD_"|"
.. Q
. Q
Q ORD
;
IWARN(DFN) ; EP-RETURN IMMUNIZATION WARNINGS
Q ""
;
FORC(STG) ; EP-RESET THE HEALTH MAINT REMINDERS FOR IMMUNIZATIONS TO ACCOMODATE THE "FORECAST BOX"
N I,FSTG,YES,A,B,IMM,CPT,N,TOT,TMP
S TMP=$NA(^TMP("VEN PRNT",$J,1))
S YES="~Yes~",FSTG="",STG="|"_STG,N=0
I STG["Yes" S TOT=$L(STG,YES) F I=1:1:TOT D
. S A=$P(STG,YES,1) S IMM=$P(A,"|",$L(A,"|"))
. S B=$P(STG,YES,2,99) S CPT=$P(B,"~")
. S STG=B
. I $L(FSTG) S FSTG=FSTG_U
. S FSTG=FSTG_IMM_" due"
. I $L(CPT) S FSTG=FSTG_" ("_CPT_")"
. Q
F I=9:1:25 S N=N+1,%=$P(FSTG,U,N) I $L(%) S @TMP@("h"_I)=%
Q
;
CLN ; EP CLEAN OUT IMMUNIZATIONS
N I,TMP
S TMP=$NA(^TMP("VEN PRNT",$J,1))
F I=9:1:25 S @TMP@("h"_I)=""
Q
;
NEWIMM(DFN) ; EP-GET DATA FROM NEW IMMUNIZATION PACKAGE
N ARR,TYPE,LINE,CNT,ISTG,LAST,X
D CLN ; CLEAN OUT IMMUNIZATION WARNINGS AND START OVER WITH NEW DATA
D IMMBI^BIAPCHS(DFN,.ARR) ; GET THE IMMUNIZATION ARRAY FRO IMM PKG
K BIDLLP,BIDLLID,BIDLLRUN,BIFDT,BIRESULT,BISITE,%T,%Y,DX,DY,XY
I '$D(ARR) Q "" ; MUST HAVE SOME RESULTS
S TYPE="",LINE=0,CNT=8,ISTG="",LAST="",MCNT=0
F S LINE=$O(ARR(LINE)) Q:'LINE S X=$G(ARR(LINE,0)) I $L(X)>1 D ; BUILD MAIL MERGE FIELDS AND THE IMMUNIZATION STRING
. I X["IMMUNIZATION FORECAST" S TYPE="NEWFORC" Q
. I X["IMMUNIZATION HISTORY" S TYPE="NEWHX" Q
. X ("D "_TYPE_"(X,LINE)") ; SET IMM HEALTH MAINT REMINDERS FOR BOTH HX AND FORECAST
. Q
I $L(ISTG) S ISTG=ISTG_"|"
Q ISTG
;
NEWFORC(STG,LINE) ; EP-NEW IMMINUZATION FORECASTS
N X,Y,%,CPT,IIEN,GBL
S GBL=$NA(^TMP("VEN PRNT",$J,1))
I STG'[" due " Q
I STG["past due" S X=$P(STG,"past due") ; GET IMMINUZATION ; PATCHED BY GIS/ITSC
E S X=$P(STG,"due") ; PATCHED BY GIS/ITSC
S X=$$STRIP^VENPCCU(X) ; STRIP OFF BLANKS
I '$L(X) Q ; THIS POINT X = NAME OF IMMUNIZATON
S CNT=CNT+1 I CNT>25 Q
S IIEN=$O(^AUTTIMM("D",X,0)),CPT="" I 'IIEN Q
S CPT=$P($G(^AUTTIMM(IIEN,0)),U,11)
I $L(CPT) S CPT="("_CPT_")"
S @GBL@("h"_CNT)="__"_X_" due now "_CPT ; REFRESH THE IMM FORCAST MAIL MERGE FIELD
S @TMP@("DUE",X)="h"_CNT ; TMP ARRAY USED IN THE PEDS FORM
Q
;
NEWHX(STG,LINE) ; EP-NEW IMM HISTORY
N WARN,NEXT,IMM,TYPE,DATE,LOC,DUE,X,Y,Z,GBL
S GBL=$NA(^TMP("VEN PRNT",$J,1))
S DUE="No"
S X=$E(STG,1,27) S X=$$STRIP^VENPCCU(X) I '$L(X) Q
S IMM=X
S X=$E(STG,28,37) S X=$$STRIP^VENPCCU(X) I X'?2N1"/"2N1"/"2N Q ; THIS BLOCKS A "Reaction" LINE FROM HX
S DATE=X
S X=$E(STG,38,45) S X=$$STRIP^VENPCCU(X)
S TYPE=X
S X=$E(STG,46,59) S X=$$STRIP^VENPCCU(X)
S LOC=X
I TMP'="IMM" D Q ; PEDS FORM HX FROM IMM^VENPCCS2
. I $D(@TMP@("DUE",IMM)) S DUE="Yes"
. S Z=DATE_"_"_TYPE_"_"_LOC
. S ISTG=ISTG_$S(LAST="":"",IMM=LAST:"`",1:"|") ; DELIMITER
. I IMM'=LAST S ISTG=ISTG_IMM_"~"_DUE_"~~"
. S ISTG=ISTG_Z,LAST=IMM
. Q
I TMP="IMM" D ; GENL IMM HX FROM IF^VENPCC1C (IMM 8.0 AND HIGHER)
. S MCNT=MCNT+1
. I $O(ARR(999),-1)<49,MCNT>1,IMM'=LAST,MCNT<51 S @GBL@("ihx"_MCNT)=" " S MCNT=MCNT+1 ; SPACER LINE
. I MCNT<51 S @GBL@("ihx"_MCNT)=IMM_" "_DATE_" "_TYPE_" "_LOC ; POPULATE IMM HX LIST
. S LAST=IMM
. Q
S NEXT=$G(ARR(LINE+1,0)) ; MAY NEED TO APPEND IMM FORCAST NOTICE WITH ADVERSE RXN INFO!
I NEXT'["Reaction" Q ; CHECK FOR ADVERSE REACTION
S Y=$G(@TMP@("DUE",IMM)) I '$L(Y) Q ; GET MM FIELD
S X=$G(^TMP("VEN PRNT",$J,1,Y)) ; GET MESSAGE
I $L(X),X'["Rxn: " S X=X_" (Rxn: "_$E($P(NEXT,"Reaction: ",2),1,12)_")"
S ^TMP("VEN PRNT",$J,1,Y)=X ; APPEND REACTION NOTICE TO END OF DUE NOW NOTICE
Q
;
VENPCCS2 ; IHS/OIT/GIS - POPULATE OCX IMMUNIZATIONS OBJECT AND MAIL MERGRE FIELDS ; 16 Nov 2007 10:04 AM
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ; SUPPORTS IMM PGK VER 7 AND HIGHER
+4 ; DEAD CODE IN 2.5
+5 ;
IMM(DFN) ; EP-GET IMMUNIZATION DATA AND RETURN IT IN A FORMATTED STRING
+1 IF '$DATA(^DPT(+$GET(DFN),0))
QUIT ""
+2 NEW STG1,STG2,X,TMP,STG
+3 SET TMP="^TMP(""VEN IMM"","_$JOB_")"
KILL @TMP
+4 SET X=$TEXT(IMMHX^BIRPC)
IF '$LENGTH(X)
QUIT ""
+5 SET X=$TEXT(IMMFORC^BIRPC)
IF '$LENGTH(X)
QUIT ""
+6 ; ACCOMODATES NEW IMMINUZATION PKG
IF $LENGTH($TEXT(VER^BILOGO))
IF $$VER^BILOGO>7.99
IF $LENGTH($TEXT(IMMBI^BIAPCHS))
SET STG=$$NEWIMM(DFN)
KILL @TMP
QUIT STG
+7 DO IMMHX^BIRPC(.STG1,DFN)
+8 DO IMMFORC^BIRPC(.STG2,DFN)
ABORT IF '$LENGTH(STG1)
IF '$LENGTH(STG2)
QUIT ""
STG DO ANAL(STG1,STG2)
FMT SET STG=$$FORMAT
+1 KILL @TMP
+2 IF '$GET(WFLG)
DO CLN
+3 ; MAIL MERGE FORECASTING COMPONENT
DO FORC(STG)
+4 QUIT STG
+5 ;
ANAL(STG1,STG2) ; EP-ANALYSIS OF THE HX AND FORCAST STRINGS
+1 NEW B,PCE1,PCE2,X,Y,%DT,CPT,CPTIEN,ICLASS,IDATE,IIEN,ILOC,IMM,IR,IRNO,STG,STYPE,VIIEN
+2 SET B="|"
+3 FOR PCE1=1:1:$LENGTH(STG1,U)
SET X=$PIECE(STG1,U,PCE1)
IF X'=""
Begin DoDot:1
+4 SET ICLASS=$PIECE(X,B,2)
IF '$LENGTH(ICLASS)
QUIT
+5 SET IMM=$PIECE(X,B,6)
IF '$LENGTH(IMM)
QUIT
+6 SET VIIEN=+$PIECE(X,B,4)
IF 'VIIEN
QUIT
+7 SET ILOC=$PIECE(X,B,5)
+8 SET STYPE=$PIECE(X,B,6)
IF '$LENGTH(STYPE)
SET STYPE="OTHER"
+9 SET IDATE=$PIECE(X,B,7)
IF IDATE
SET IDATE=$EXTRACT(IDATE,1,11)
SET %DT=""
SET X=IDATE
DO ^%DT
+10 IF Y'?7N
QUIT
+11 SET IDATE=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))
+12 SET %=$GET(^AUPNVIMM(VIIEN,0))
SET IRNO=$PIECE(%,U,6)
SET IIEN=+%
IF 'IIEN
QUIT
+13 SET IR=""
IF IRNO
SET %=$PIECE($GET(^DD(9000010.11,.06,0)),U,3)
SET %=";"_%
SET Y=$PIECE(%,(";"_IRNO_":"),2)
SET IR=$PIECE(Y,";")
IF IR="OTHER"
SET IR="UNSPECIFIED REACTION"
+14 IF $LENGTH(IR)
SET @TMP@("IR",ICLASS,IR)=""
IF $GET(WFLG)
QUIT
+15 SET @TMP@("ORD",STYPE,2,ICLASS,PCE1)=IDATE_"_"_IMM_"_"_ILOC
+16 QUIT
End DoDot:1
+17 KILL STG1
+18 ; WARNINGS ONLY
IF $GET(WFLG)
QUIT
+19 FOR PCE2=1:1:$LENGTH(STG2,U)
SET X=$PIECE(STG2,U,PCE2)
IF X'=""
Begin DoDot:1
+20 SET IMM=$PIECE(X,B,1)
IF '$LENGTH(IMM)
QUIT
+21 SET IMM=$$STRIP^VENPCCU(IMM)
+22 SET DUE="Yes"
+23 SET ICLASS=IMM
IF IMM?1N1"-"1.E
SET ICLASS=$PIECE(IMM,"-",2,99)
+24 SET CPT=""
SET STYPE="OTHER"
SET IIEN=$ORDER(^AUTTIMM("D",ICLASS,0))
+25 IF IIEN
Begin DoDot:2
+26 SET STNO=+$PIECE($GET(^AUTTIMM(IIEN,0)),U,9)
SET STYPE=$PIECE($GET(^BISERT(STNO,0)),U)
+27 IF STYPE=""
SET STYPE="OTHER"
+28 SET CPTIEN=+$PIECE($GET(^AUTTIMM(IIEN,0)),U,11)
SET CPT=$PIECE($GET(^ICPT(CPTIEN,0)),U)
+29 QUIT
End DoDot:2
+30 SET @TMP@("ORD",STYPE,1,ICLASS,PCE2)=IMM_"~"_DUE_"~"_CPT_"~"
+31 QUIT
End DoDot:1
+32 KILL STG2
+33 SET STYPE=""
FOR
SET STYPE=$ORDER(@TMP@("ORD",STYPE))
IF STYPE=""
QUIT
SET ICLASS=""
FOR
SET ICLASS=$ORDER(@TMP@("ORD",STYPE,2,ICLASS))
IF ICLASS=""
QUIT
Begin DoDot:1
+34 IF '$DATA(@TMP@("ORD",STYPE,1,ICLASS))
SET @TMP@("ORD",STYPE,1,ICLASS,1)=ICLASS_"~No~~"
+35 QUIT
End DoDot:1
+36 QUIT
+37 ;
FORMAT() ; EP-FORMAT THE OUTPUT STRINGS
+1 NEW WARN,ORD,HX,IIEN,ICLASS,CNT,IIEN,IR,STYPE,CNT1,CNT2,ICLASS
+2 SET WARN=""
SET IIEN=0
+3 SET ICLASS=""
SET CNT=0
+4 IF $GET(WFLG)
IF $DATA(@TMP@("IR"))
FOR
SET ICLASS=$ORDER(@TMP@("IR",ICLASS))
IF ICLASS=""
QUIT
SET IR=""
FOR
SET IR=$ORDER(@TMP@("IR",ICLASS,IR))
IF IR=""
QUIT
Begin DoDot:1
+5 IF 'CNT
SET CNT=1
SET WARN=WARN_$SELECT($LENGTH(WARN):" ",1:"")_"Warnings: "_ICLASS_" CAUSES "_IR
QUIT
+6 SET WARN=WARN_", "_ICLASS_" CAUSES "_IR
+7 QUIT
End DoDot:1
+8 ; WARNINGS ONLY
IF $GET(WFLG)
QUIT WARN
+9 SET STYPE=""
SET ORD=""
+10 FOR
SET STYPE=$ORDER(@TMP@("ORD",STYPE))
IF STYPE=""
QUIT
SET ICLASS=""
FOR
SET ICLASS=$ORDER(@TMP@("ORD",STYPE,1,ICLASS))
IF ICLASS=""
QUIT
Begin DoDot:1
+11 SET CNT1=0
FOR
SET CNT1=$ORDER(@TMP@("ORD",STYPE,1,ICLASS,CNT1))
IF 'CNT1
QUIT
Begin DoDot:2
+12 SET ORD=ORD_@TMP@("ORD",STYPE,1,ICLASS,CNT1)
SET CNT2=0
SET CNT=0
+13 FOR
SET CNT2=$ORDER(@TMP@("ORD",STYPE,2,ICLASS,CNT2))
IF 'CNT2
QUIT
Begin DoDot:3
+14 IF CNT
SET ORD=ORD_"`"
+15 IF '$TEST
SET CNT=1
+16 SET ORD=ORD_@TMP@("ORD",STYPE,2,ICLASS,CNT2)
+17 QUIT
End DoDot:3
+18 SET ORD=ORD_"|"
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT ORD
+22 ;
IWARN(DFN) ; EP-RETURN IMMUNIZATION WARNINGS
+1 QUIT ""
+2 ;
FORC(STG) ; EP-RESET THE HEALTH MAINT REMINDERS FOR IMMUNIZATIONS TO ACCOMODATE THE "FORECAST BOX"
+1 NEW I,FSTG,YES,A,B,IMM,CPT,N,TOT,TMP
+2 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+3 SET YES="~Yes~"
SET FSTG=""
SET STG="|"_STG
SET N=0
+4 IF STG["Yes"
SET TOT=$LENGTH(STG,YES)
FOR I=1:1:TOT
Begin DoDot:1
+5 SET A=$PIECE(STG,YES,1)
SET IMM=$PIECE(A,"|",$LENGTH(A,"|"))
+6 SET B=$PIECE(STG,YES,2,99)
SET CPT=$PIECE(B,"~")
+7 SET STG=B
+8 IF $LENGTH(FSTG)
SET FSTG=FSTG_U
+9 SET FSTG=FSTG_IMM_" due"
+10 IF $LENGTH(CPT)
SET FSTG=FSTG_" ("_CPT_")"
+11 QUIT
End DoDot:1
+12 FOR I=9:1:25
SET N=N+1
SET %=$PIECE(FSTG,U,N)
IF $LENGTH(%)
SET @TMP@("h"_I)=%
+13 QUIT
+14 ;
CLN ; EP CLEAN OUT IMMUNIZATIONS
+1 NEW I,TMP
+2 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+3 FOR I=9:1:25
SET @TMP@("h"_I)=""
+4 QUIT
+5 ;
NEWIMM(DFN) ; EP-GET DATA FROM NEW IMMUNIZATION PACKAGE
+1 NEW ARR,TYPE,LINE,CNT,ISTG,LAST,X
+2 ; CLEAN OUT IMMUNIZATION WARNINGS AND START OVER WITH NEW DATA
DO CLN
+3 ; GET THE IMMUNIZATION ARRAY FRO IMM PKG
DO IMMBI^BIAPCHS(DFN,.ARR)
+4 KILL BIDLLP,BIDLLID,BIDLLRUN,BIFDT,BIRESULT,BISITE,%T,%Y,DX,DY,XY
+5 ; MUST HAVE SOME RESULTS
IF '$DATA(ARR)
QUIT ""
+6 SET TYPE=""
SET LINE=0
SET CNT=8
SET ISTG=""
SET LAST=""
SET MCNT=0
+7 ; BUILD MAIL MERGE FIELDS AND THE IMMUNIZATION STRING
FOR
SET LINE=$ORDER(ARR(LINE))
IF 'LINE
QUIT
SET X=$GET(ARR(LINE,0))
IF $LENGTH(X)>1
Begin DoDot:1
+8 IF X["IMMUNIZATION FORECAST"
SET TYPE="NEWFORC"
QUIT
+9 IF X["IMMUNIZATION HISTORY"
SET TYPE="NEWHX"
QUIT
+10 ; SET IMM HEALTH MAINT REMINDERS FOR BOTH HX AND FORECAST
XECUTE ("D "_TYPE_"(X,LINE)")
+11 QUIT
End DoDot:1
+12 IF $LENGTH(ISTG)
SET ISTG=ISTG_"|"
+13 QUIT ISTG
+14 ;
NEWFORC(STG,LINE) ; EP-NEW IMMINUZATION FORECASTS
+1 NEW X,Y,%,CPT,IIEN,GBL
+2 SET GBL=$NAME(^TMP("VEN PRNT",$JOB,1))
+3 IF STG'[" due "
QUIT
+4 ; GET IMMINUZATION ; PATCHED BY GIS/ITSC
IF STG["past due"
SET X=$PIECE(STG,"past due")
+5 ; PATCHED BY GIS/ITSC
IF '$TEST
SET X=$PIECE(STG,"due")
+6 ; STRIP OFF BLANKS
SET X=$$STRIP^VENPCCU(X)
+7 ; THIS POINT X = NAME OF IMMUNIZATON
IF '$LENGTH(X)
QUIT
+8 SET CNT=CNT+1
IF CNT>25
QUIT
+9 SET IIEN=$ORDER(^AUTTIMM("D",X,0))
SET CPT=""
IF 'IIEN
QUIT
+10 SET CPT=$PIECE($GET(^AUTTIMM(IIEN,0)),U,11)
+11 IF $LENGTH(CPT)
SET CPT="("_CPT_")"
+12 ; REFRESH THE IMM FORCAST MAIL MERGE FIELD
SET @GBL@("h"_CNT)="__"_X_" due now "_CPT
+13 ; TMP ARRAY USED IN THE PEDS FORM
SET @TMP@("DUE",X)="h"_CNT
+14 QUIT
+15 ;
NEWHX(STG,LINE) ; EP-NEW IMM HISTORY
+1 NEW WARN,NEXT,IMM,TYPE,DATE,LOC,DUE,X,Y,Z,GBL
+2 SET GBL=$NAME(^TMP("VEN PRNT",$JOB,1))
+3 SET DUE="No"
+4 SET X=$EXTRACT(STG,1,27)
SET X=$$STRIP^VENPCCU(X)
IF '$LENGTH(X)
QUIT
+5 SET IMM=X
+6 ; THIS BLOCKS A "Reaction" LINE FROM HX
SET X=$EXTRACT(STG,28,37)
SET X=$$STRIP^VENPCCU(X)
IF X'?2N1"/"2N1"/"2N
QUIT
+7 SET DATE=X
+8 SET X=$EXTRACT(STG,38,45)
SET X=$$STRIP^VENPCCU(X)
+9 SET TYPE=X
+10 SET X=$EXTRACT(STG,46,59)
SET X=$$STRIP^VENPCCU(X)
+11 SET LOC=X
+12 ; PEDS FORM HX FROM IMM^VENPCCS2
IF TMP'="IMM"
Begin DoDot:1
+13 IF $DATA(@TMP@("DUE",IMM))
SET DUE="Yes"
+14 SET Z=DATE_"_"_TYPE_"_"_LOC
+15 ; DELIMITER
SET ISTG=ISTG_$SELECT(LAST="":"",IMM=LAST:"`",1:"|")
+16 IF IMM'=LAST
SET ISTG=ISTG_IMM_"~"_DUE_"~~"
+17 SET ISTG=ISTG_Z
SET LAST=IMM
+18 QUIT
End DoDot:1
QUIT
+19 ; GENL IMM HX FROM IF^VENPCC1C (IMM 8.0 AND HIGHER)
IF TMP="IMM"
Begin DoDot:1
+20 SET MCNT=MCNT+1
+21 ; SPACER LINE
IF $ORDER(ARR(999),-1)<49
IF MCNT>1
IF IMM'=LAST
IF MCNT<51
SET @GBL@("ihx"_MCNT)=" "
SET MCNT=MCNT+1
+22 ; POPULATE IMM HX LIST
IF MCNT<51
SET @GBL@("ihx"_MCNT)=IMM_" "_DATE_" "_TYPE_" "_LOC
+23 SET LAST=IMM
+24 QUIT
End DoDot:1
+25 ; MAY NEED TO APPEND IMM FORCAST NOTICE WITH ADVERSE RXN INFO!
SET NEXT=$GET(ARR(LINE+1,0))
+26 ; CHECK FOR ADVERSE REACTION
IF NEXT'["Reaction"
QUIT
+27 ; GET MM FIELD
SET Y=$GET(@TMP@("DUE",IMM))
IF '$LENGTH(Y)
QUIT
+28 ; GET MESSAGE
SET X=$GET(^TMP("VEN PRNT",$JOB,1,Y))
+29 IF $LENGTH(X)
IF X'["Rxn: "
SET X=X_" (Rxn: "_$EXTRACT($PIECE(NEXT,"Reaction: ",2),1,12)_")"
+30 ; APPEND REACTION NOTICE TO END OF DUE NOW NOTICE
SET ^TMP("VEN PRNT",$JOB,1,Y)=X
+31 QUIT
+32 ;
