VENPCCS2.m

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      ;