9:16 AM  16-MAY-96
Patch routines for Immunization 6.8.  Restore routines and D ^AMCHPOST.  Mike Remillard, ANMC/IHS
AMCHPOST
AMCHPOST ;IHS/ANMC/MWR - POST-INIT CONTROL;  [ 05/16/96  3:05 AM ]
 ;;6.8;IMMUNIZATION TRACKING SYSTEM;**1**;APR 30, 1996
 ;
 ;---> PATCH TO UPDATE IMMS DUE TABLE                           ;MWR
 D MONTH
 ;---> END PATCH                                                ;MWR
 Q
EN D ^AMCHMMS,^AMCHVPI
MMR W !!,"The 'MMR' vaccine is now considered a 'series' vaccine.",!,"Series vaccines are handled somewhat differently by the",!,"Vaccine Accountability Report and some of the",!,"'due for immunizations' reports.  In order to work properly,"
 W !,"the series number for each 'series' vaccine must be indicated",!,"for each dose received by each child.  Most 'MMR' vaccines",!,"were entered without indicating the series.  This utility"
 W !,"will automatically add a series '1' to each 'MMR' for",!,"every child IF no series has already been indicated.",!,"It will NOT change any data if a series number has already",!,"been indicated for the 'MMR'."
 S DIR(0)="YO",DIR("A")="Proceed with MMR series update",DIR("B")="NO"
 W !
 D ^DIR K DIR
 I Y'=1 W !!,"No MMR series update has occured." Q
 S AMCHV=$O(^AUTTIMM("D","MMR",0))
 I 'AMCHV W !!,"I could not find MMR in the IMMUNIZATION file.",!,"No MMR series update has occured." Q
 I $P(^AUTTIMM(AMCHV,0),U,3)'=17 W !!,"I could not find a valid MMR in the IMMUNIZATION file.",!,"No MMR series update has occured." Q
 W ! D WAIT^DICD W !
 S AMCH=0
 F  S AMCH=$O(^AUPNVIMM(AMCH)) Q:'AMCH  I $D(^(AMCH,0)),$P(^(0),U)=AMCHV,$P(^(0),U,4)="" S $P(^(0),U,4)=1
 W !,"MMR series update has completed successfully."
 Q
 ;
 ;
MONTH ;EP;TO SET MONTH AT WHICH MMR, HIB AND DPT ARE DUE.             ;MWR
 D ^XBKVAR
 ;---> NEW VARIABLES                                             ;MWR
 N AMCHMMR,AMCHHIB,AMCHDPT,DIR
 ;
 ;---> CHOOSE MMR SERIES 1 DUE AT 12 OR 15 MONTHS                ;MWR
 W !!?5,"The current MMR setting is: "
 W $S($D(^AMCH(83,7,"G",1,"V",3,0)):12,1:15)," MONTHS"
 S DIR(0)="SO^1:MMR due at 12 Months;2:MMR due at 15 Months"
 S DIR("A")="     Which one"
 D ^DIR
 S AMCHMMR=$S("12"[+Y:+Y,1:"")
 I AMCHMMR=1 D
 .S ^AMCH(83,7,"G",1,"V",3,0)="3^1"
 .S ^AMCH(83,7,"G",1,"V","B",3,3)=""
 I AMCHMMR=2 D
 .K ^AMCH(83,7,"G",1,"V",3,0)
 .K ^AMCH(83,7,"G",1,"V","B",3,3)
 ;
 ;
 ;---> CHOOSE HIB (ONLY ONE SERIES) DUE AT 12 OR 15 MONTHS       ;MWR
 W !!!?5,"The current HIB setting is: "
 W $S(+^AMCH(83,7,"G",1,"V",4,0)=7:12,1:15)," MONTHS"
 S DIR(0)="SO^1:Last HIB due at 12 Months;2:Last HIB due at 15 Months"
 S DIR("A")="     Which one"
 D ^DIR
 S AMCHHIB=$S("12"[+Y:+Y,1:"")
 I AMCHHIB=1 D
 .S ^AMCH(83,7,"G",1,"V",4,0)="7^1"
 .S ^AMCH(83,7,"G",1,"V","B",7,4)=""
 .K ^AMCH(83,7,"G",1,"V","B",4,4)
 .K ^AMCH(83,7,"G",1,"V",5,0)
 .K ^AMCH(83,7,"G",1,"V","B",5,5)
 I AMCHHIB=2 D
 .S ^AMCH(83,7,"G",1,"V",4,0)="4^3"
 .S ^AMCH(83,7,"G",1,"V","B",4,4)=""
 .S ^AMCH(83,7,"G",1,"V",5,0)="5^3"
 .S ^AMCH(83,7,"G",1,"V","B",5,5)=""
 .K ^AMCH(83,7,"G",1,"V","B",7)
 ;
 ;
 ;---> CHOOSE DPT SERIES 4 DUE AT 12 OR 15 MONTHS                ;MWR
 W !!!?5,"The current DPT setting is: "
 W $S($P(^AMCH(83,7,"G",1,"V",1,0),U,2)=4:12,1:15)," MONTHS"
 S DIR(0)="SO^1:DPT series 4 due at 12 Months"
 S DIR(0)=DIR(0)_";2:DPT series 4 due at 15 Months"
 S DIR("A")="     Which one"
 D ^DIR
 S AMCHDPT=$S("12"[+Y:+Y,1:"")
 I AMCHDPT=1 D
 .S ^AMCH(83,7,"G",1,"V",1,0)="1^4"
 .S ^AMCH(83,7,"G",1,"V","B",1,1)=""
 .S ^AMCH(83,3,"G",1,"V",1,0)="1^4"
 .S ^AMCH(83,3,"G",1,"V","B",1,1)=""
 I AMCHDPT=2 D
 .S ^AMCH(83,7,"G",1,"V",1,0)="1^3"
 .S ^AMCH(83,7,"G",1,"V","B",1,1)=""
 .S ^AMCH(83,3,"G",1,"V",1,0)="1^4"
 .S ^AMCH(83,3,"G",1,"V","B",1,1)=""
 ;
HEP ;
 ;---> ADD HEP-B AS DUE FROM AGES 1-5
 W !!!?5,"Do you wish to make HEP-B due for ages 1-5 years?"
 S DIR(0)="Y",DIR("A")="     Enter Yes or No"
 D ^DIR W !
 I $D(DIRUT) Q
 D @$S(Y:"SETHEP",1:"KILLHEP")
 W !!?5,"Settings complete."
 N DIR,DIRUT,X,Y S DIR(0)="E" W ! D ^DIR W !
 Q
 ;
SETHEP ;EP
 ;---> MAKE HEP-B DUE FOR AGES 1-5 YEARS.
 S ^AMCH(83,7,"G",1,"V",9,0)="9^3"
 S ^AMCH(83,7,"G",1,"V","B",9,9)=""
 S ^AMCH(83,3,"G",1,"V",9,0)="9^3"
 S ^AMCH(83,3,"G",1,"V","B",9,9)=""
 S ^AMCH(83,2,"G",1,"V",9,0)="9^3"
 S ^AMCH(83,2,"G",1,"V","B",9,9)=""
 S ^AMCH(83,1,"G",1,"V",9,0)="9^3"
 S ^AMCH(83,1,"G",1,"V","B",9,9)=""
 S ^AMCH(83,8,"G",1,"V",9,0)="9^3"
 S ^AMCH(83,8,"G",1,"V","B",9,9)=""
 Q
 ;
KILLHEP ;EP
 ;---> MAKE HEP-B NOT DUE FOR AGES 1-5 YEARS.
 K ^AMCH(83,7,"G",1,"V",9,0)
 K ^AMCH(83,7,"G",1,"V","B",9,9)
 K ^AMCH(83,3,"G",1,"V",9,0)
 K ^AMCH(83,3,"G",1,"V","B",9,9)
 K ^AMCH(83,2,"G",1,"V",9,0)
 K ^AMCH(83,2,"G",1,"V","B",9,9)
 K ^AMCH(83,1,"G",1,"V",9,0)
 K ^AMCH(83,1,"G",1,"V","B",9,9)
 K ^AMCH(83,8,"G",1,"V",9,0)
 K ^AMCH(83,8,"G",1,"V","B",9,9)
 Q

AMCHQL
AMCHQL ;IHS/ANMC/MWR - QUEUE IMM. DUE LETTERS;  [ 05/13/96  8:49 AM ]
 ;;6.8;IMMUNIZATION TRACKING SYSTEM;**1**;MAR 01, 1995
Z K AMCHDT
 S AMCHRPT="Due Letters"
A0 S AMCHOFFS=0,AMCHO=1,AMCHPT=0
 D HEAD
 K AMCHTSK
A01 S:'$D(AMCHDT) AMCHDT=DT
 D ^AMCHQUD
 G END:$D(DTOUT)!$D(DUOUT)
 I '$D(AMCHDT) W *7,"  You must enter a date!",!!,?5,"Enter a '^' to return to the report menu.",! G A01
A1 W !
 S DIR(0)="YO",DIR("A")="Do you want to print letters for individual patients",DIR("B")="NO"
 D ^DIR
 K DIR
 ;
 ;---> PATCH TO SAVE WHETHER PRINTING INDIVIDUALS OR BATCH.       ;MWR
 ;---> IF BATCH, DO NOT PRINT LETTERS WHERE MINIMUM INTERVAL HAS  ;MWR
 ;---> NOT BEEN REACHED FOR ALL IMMS.
 S AMCH("INDIV")=$S(Y=1:1,1:0)
 ;---> END PATCH                                                  ;MWR
 ;
 G END:$D(DTOUT)!$D(DUOUT),C1:'Y
 D ^AMCHUTAB
 S AMCHMXA=$P(AMCHPAR,U,7)*30.44,AMCHORD=0
A2 K AMCH("DFN")
 D ^AMCHUPT
 G END:$D(DTOUT)!$D(DUOUT),A9:'$D(AMCH("DFN"))
 I '$D(^AMCH(85,AMCH("DFN"),1)) W !!,"This patient is NOT on the immunization register." G A2
 I $P(^AMCH(85,AMCH("DFN"),1),U,1)'="A" W !!,"This patient's Immunization Register status is INACTIVE." G A2
 S AMCHINDV="",AMCH("DUE")=""
 D XA1^AMCHUSRH
 G:AMCH("DUE")]"" A5
 W *7,!
A3 W !!,"This patient is NOT DUE for any immunizations, but do you want to print"
 S DIR(0)="YO",DIR("A")="a WELL CHILD appointment letter",DIR("B")="NO"
 D ^DIR
 K DIR
 G END:$D(DTOUT),A2:$D(DUOUT)!'Y
A5 D TSK^AMCHU:'$D(AMCHTSK)
 S AMCHORD=AMCHORD+1,^TMP("AMCHPT",AMCHTSK,AMCHORD,AMCH("DFN"))=AMCH("DUE")
 W !?10,"  Recorded"
 G A2
A9 K AMCHT
 S AMCHPT=1
 G END:'$D(AMCHTSK),C1
C1 S AMCHPO=""
C2 W !
 S DIR(0)="YO",DIR("A")="Do you want to print the Clinic Location on the letters",DIR("B")="YES"
 D ^DIR
 K DIR
 G END:$D(DTOUT),A0:$D(DUOUT),C4:'Y
 S AMCHPO=$P(AMCHPAR,U,3)
C3 W !
 S DIR(0)="FO^1:30",DIR("A")="Location Name"
 S:$P(AMCHPO,U,1)]"" DIR("B")=$P(AMCHPO,U,1),DIR("?")="Enter the location name to be printed on the letters."
 D ^DIR
 K DIR
 G END:$D(DTOUT),C1:$D(DUOUT)
 G C4:Y=""
 I Y?1A.ANP,$L(Y)<40,$L(Y)>3 S $P(AMCHPO,U,1)=Y G C4
 W *7,"  ??"
 G C3
C4 W !
 S DIR(0)="YO",DIR("A")="Do you want to print the above date as the clinic date",DIR("B")="YES"
 D ^DIR
 K DIR
 G END:$D(DTOUT),C3:$D(DUOUT)
 S $P(AMCHPO,U,2)=$P(AMCHDT,U,Y)
C6 W !
 S DIR(0)="YO",DIR("A")="Ask the parents to call for an appointment for their child",DIR("B")="NO",AMCHLTR="",DIR("?",1)="Enter YES only if you want the letter to ask the parents",DIR("?")="to call you to set up an appointment time."
 D ^DIR
 K DIR
 G END:$D(DTOUT),C6:$D(DUOUT)
 S:Y AMCHLTR=1
C9 K AMCHPGM
 S AMCHPGM="^AMCHQLS"
 F AMCH("I")="AMCHOFFS","AMCHPT","AMCHPO","AMCHLTR" S AMCHPGM(AMCH("I"))=@AMCH("I")
 G ^AMCHQ:AMCHPT
 W !!,"How would you like the letters to be sorted ? "
 G XA1^AMCHUQ
END K AMCHTSK,AMCHT
 Q
HEAD W:$D(IOF) @IOF
 D:'$D(AMCHPAR) ^AMCHU
 W !,?80-$L($P(AMCHPAR,U,3))\2,$P(AMCHPAR,U,3),!
 W !,?28,"Immunization Due Letters",!
 Q

AMCHQLP1
AMCHQLP1 ;IHS/ANMC/MWR - PRINT DUE LETTERS;  [ 05/13/96  8:50 AM ]
 ;;6.8;IMMUNIZATION TRACKING SYSTEM;**1**;APR 30, 1996
 ;;PRINT DUE LETTERS
 I AMCH("DUE")="",$D(AMCHORD) G A0
 D SB2^AMCHALG
 ;
 ;---> BEGIN PATCH TO CANCEL THIS LETTER IF NO IMMS DUE, UNLESS  ;MWR
 ;---> THIS IS AN INDIVIDUALLY PRINTED LETTER FOR WELL CHILD.    ;MWR
 D MWRFIX
 Q:('$D(AMCH("NEEDS"))&('$G(AMCH("INDIV"))))
 ;---> END PATCH                                               ;MWR
 ;
 Q:AMCH("DUE")=""
A0 K AMCH("A")
 D A1
B1 D HEAD
 S AMCH("G")=$S($D(^AMCH(85,AMCH("DFN"),1)):$P(^(1),U,2),1:"")
 S:AMCH("G")="" AMCH("G")="Parent"
 W !!!,?5,"Dear Parent,",!
 I $D(^DPT(AMCH("DFN"),0)) S AMCH("G")=$P(^(0),U,1),AMCH("L")=$P(AMCH("G"),",",1),AMCH("G")=$P(AMCH("G"),",",2,99) S:$E(AMCH("G"),1)=" " AMCH("G")=$E(AMCH("G"),2,99) S AMCH("G")=$P(AMCH("G")," ",1)_" "_AMCH("L")
 E  S AMCH("G")=""
 W !,?5,"Your child"
 W:AMCH("G")]"" " ",AMCH("G")
 W " is due for WELL CHILD CARE or",!,?5,"IMMUNIZATIONS.  According to our records the following",!,?5,"immunizations have already been received:",!!
 S AMCH("D")=""
 I '$D(AMCH("A")) W !,?10,"NO Immunizations on our records!"
B2 S AMCH("D")=$O(AMCH("A",AMCH("D")))
 I AMCH("D")]"" D SBW G B2
 W !!,?5,$S(AMCH("G")="":"Your child",1:$P(AMCH("G")," ",1))," is now due for "
 I AMCH("DUE")="" W "WELL CHILD CARE.",!! G B3
 ;
 ;---> PATCH TO PRINT "WELL CHILD CARE" FOR INDIVIDUAL LETTERS,    ;MWR
 ;---> EVEN IF NOT IMMS DUE.
 I '$D(AMCH("NEEDS"))&($G(AMCH("INDIV"))) W "WELL CHILD CARE.",!! G B3
 ;---> END PATCH.                                                  ;MWR
 ;
 W "the immunizations indicated below:",!!
 D SB2^AMCHALG
 ;
 ;---> PATCH TO ELIMINATE IMMS WITHOUT MINIMUM INTERVAL.           ;MWR
 D MWRFIX
 ;---> END PATCH.                                                  ;MWR
 ;
 D B21^AMCHQDP1
 W !
 I $D(IOST),$E(IOST,1,2)="P-"!($E(IOST,1,2)="S-") S DA=AMCH("DFN"),DR="104.5////"_DT,DIE="^AMCH(85," D ^DIE K DIE,DR,DA
B3 I $E($G(IOST),1,2)="C-" D SBRS^AMCHU
 W !,?5,"If you feel our records are not correct, notify us so we",!,?5,"may make the corrections to update our records.  Otherwise,"
 G:AMCHLTR=1 B6
 W !,?5,"please bring your child to the clinic at the time and location",!,?5,"given below:"
 G B7
B6 W !,?5,"please call for an appointment for your child.  You may use the",!?5,"spaces below to note the time and date of the appointment."
B7 W !!,?6,AMCHDTA,?45,AMCHPO,!,?5,"-------------",?25,"---------------",?45,"-------------------"
 W !,?10,"Date",?30,"Time",?50,"Location"
 D TAIL
 I AMCHADDP D ^AMCHQLP3
END Q
HEAD W:$D(IOF) @IOF
 W !!,?79-$L($P(AMCHLOCA,U,1))\2,$P(AMCHLOCA,U,1)
 F AMCH("I")=7:1:10 S X=$P(AMCHADDP,U,AMCH("I")) W ! I X]"" W ?79-$L(X)/2,X
 W !,?60
 D ^%D
 Q
TAIL W !!
 F AMCH("I")=3,4 W !,?5,"PHONE #: ",$P(AMCHADDP,U,AMCH("I")),?45,$P(AMCHADDP,U,AMCH("I")+2)
 I $D(^AUPNPAT(AMCH("DFN"),41,DUZ(2),0)) W !!,?5,"IHS CHART #: ",$P(^(0),U,2)
 Q
SBW W !
 I AMCH("D") S X=AMCH("D") D DAT
 W ?10,$J(Y,12),":  " S (AMCH("C"),AMCH("N"))=0
SBW1 S AMCH("C")=$O(AMCH("A",AMCH("D"),AMCH("C")))
 Q:AMCH("C")=""
 W:AMCH("N") ", "
 S AMCH("N")=AMCH("N")+1,AMCH("V")=$P(AMCH("A",AMCH("D"),AMCH("C")),U,1),AMCH("S")=$P(AMCH("A",AMCH("D"),AMCH("C")),U,2)
 I AMCH("V"),$D(^AUTTIMM(AMCH("V"),0)) S AMCH("V")=$P(^(0),U,2) W:AMCH("S") AMCH("S")," " W AMCH("V")
 G SBW1
 Q
DAT S AMCH("M")=+$E(X,4,5),Y=$E(X,1,3)+1700,X=+$E(X,6,7)
 S:'AMCH("M") AMCH("M")=""
 S:'X X=""
 I AMCH("M") S AMCH("M")=$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",AMCH("M"))
 S Y=AMCH("M")_$S(AMCH("M")]"":" ",1:"")_$S(X:$S(X<10:" ",1:"")_X,1:"")_$S(X:", ",1:"")_Y
 Q
SB2 W !
 F AMCH("I")=1:1:5 W ?AMCH("I")*8,AMCH("I")," DTP"
 S AMCH("S")=0 W !!
 F AMCH("I")=1:1:5 I AMCH("I")'=3 S AMCH("S")=AMCH("S")+1 W ?AMCH("I")*8,AMCH("S")," OPV"
 W !!,?26,"MMR",?34,"Hib"
 Q
SB3 F AMCH("I")=1:1 S AMCH("S")=$P(AMCH("DUE"),";",AMCH("I")) Q:AMCH("S")=""  I $D(^AUTTIMM(+AMCH("S"),0)) W !,?10,$P(^(0),U,2)
 Q
A1 ;SET ARRAY OF IMMUNIZATIONS ALREADY RECEIVED
 N X,Y,Z,%
 S (X,Y)=0
 F  S Y=$O(^AUPNVIMM("AC",AMCH("DFN"),Y)) Q:Y<1  D:$D(^AUPNVIMM(Y,0))
 .S %=^AUPNVIMM(Y,0),Z=$P(%,U,1)
 .Q:'Z
 .S AMCH("SERIES")=$P(%,U,4),AMCH("VISDA")=$P(%,U,3),AMCH("D")=""
 .I AMCH("VISDA"),$D(^AUPNVSIT(AMCH("VISDA"),0)) S AMCH("D")=+$P(^(0),".",1)
 .S X=X+1,AMCH("A",AMCH("D"),X)=Z_U_AMCH("SERIES")
 Q
 ;
MWRFIX ;EP
 ;---> PATCH TO PREVENT PRINTING OF IMMS W/O MINIMUM INTERVAL.   ;MWR
 N N S N=0 F  S N=$O(AMCH("NEEDS",N)) Q:'N  D
 .K:$P(AMCH("NEEDS",N),U,5)]"" AMCH("NEEDS",N)
 Q
 ;---> END OF PATCH CODE.                                        ;MWR

AMCHQQP1
AMCHQQP1 ;IHS/ANMC/MWR - PRINT QUARTERLY IMM REPORT;  [ 05/13/96  8:50 AM ]
 ;;6.8;IMMUNIZATION TRACKING SYSTEM;**1**;APR 30, 1996
 ;;PRINT QUARTERLY IMM REPORT;
A0 F AMCH("G")=6:-1:1 D SBM,SB1 G END:$D(DUOUT)
 W !,"Totals"
 S (AMCH("A"),AMCH("B"),AMCH("C"))=""
 F AMCH("I")=1,2 S X="AMCH("""_$C(64+AMCH("I"))_""")" D
 .F AMCH("J")=1:1:6 D
 ..I $D(^TMP("AMCH",$J,AMCHTSK,"V",AMCH("J"),AMCH("I"))) S @X=@X+^(AMCH("I"))
 ;
 ;---> PATCH TO SHOW TOTAL APPROPRIATE FOR AGE.                   ;MWR
 ;---> REMOVE LEADING "+" FROM $J(AMCH("B")).
 ;W ?14,$J(AMCH("A"),4),?26,+$J(AMCH("B"),6),?34,"|"
 W ?14,$J(AMCH("A"),4),?26,$J(AMCH("B"),6),?34,"|"
 ;---> END PATCH.                                                 ;MWR
 ;
 S:AMCH("A")*AMCH("B") AMCH("C")=$J(AMCH("B")/AMCH("A"),0,3)*100
 I AMCH("C")="",AMCH("A") S AMCH("C")=0
 F AMCH("I")=3:1:20 D
 .S AMCH("N")=0
 .F AMCH("G")=1:1:6 D
 ..S:$D(^TMP("AMCH",$J,AMCHTSK,"V",AMCH("G"),AMCH("I"))) AMCH("N")=AMCH("N")+^(AMCH("I"))
 ..I AMCH("G")=6 W ?35+(AMCH("I")-3*5),$J(AMCH("N"),4)
 I AMCH("C")]"" S AMCH("C")="("_AMCH("C")_"%)" W !,?27,$J(AMCH("C"),7),?34,"|"
E1 I $D(IOST),IOST?1"P-".E W:$D(IOF) @IOF
 I AMCHTER D CON
END K AMCHM I '$D(DUOUT),AMCHQOPT G ^AMCHQQP2
 K AMCHQSCN,^TMP("AMCH",$J,AMCHTSK)
 Q
SB1 W !,?6,AMCH("F"),?20,AMCH("L",1),?34,"|"
 S (AMCH("N"),AMCH("O"),AMCH("A"))=""
 I $D(^TMP("AMCH",$J,AMCHTSK,"V",AMCH("G"),1)) S AMCH("N")=^(1) S:'AMCH("N") AMCH("N")=""
 I $D(^TMP("AMCH",$J,AMCHTSK,"V",AMCH("G"),2)) S AMCH("O")=^(2) S:'AMCH("O") AMCH("O")=""
 S:AMCH("N")*AMCH("O") AMCH("A")=$J(AMCH("O")/AMCH("N"),0,3)*100
 I AMCH("A")="",AMCH("N") S AMCH("A")=0
 W !,?5-$L(AMCH("D"))\2+($L(AMCH("D"))<5),$S(AMCH("D")'["27":AMCH("D"),1:24),?14,$J(+AMCH("N"),4),?20,AMCH("L",2),?26,$J(+AMCH("O"),6),?34,"|"
 F AMCH("I")=3:1:20 I $D(^TMP("AMCH",$J,AMCHTSK,"V",AMCH("G"),AMCH("I"))),^(AMCH("I")) W ?35+(AMCH("I")-3*5),$J(^(AMCH("I")),4)
 W !,?6,AMCH("T"),?20,AMCH("L",3),?34,"|"
 W:$D(AMCH("L",4)) !?20,AMCH("L",4),?34,"|"
 W:$D(AMCH("L",5)) !?20,AMCH("L",5)
 W:$D(AMCH("L",6)) !?20,AMCH("L",6)
 I AMCH("A")]"" S AMCH("A")="("_AMCH("A")_"%)" W ?27,$J(AMCH("A"),7),?34,"|"
 W !,"---------------------------------------------------------------------------------------------------------------------------"
 I AMCHTER,$Y>20 D CON I '$D(DUOUT) D HEAD^AMCHQQP
S19 Q
SBM S AMCH("D")=$P("3-4^5-6^7-15^16-18^19-23^24-27",U,AMCH("G")),X=$P(AMCH("D"),"-",1)
 D SBMD
 S AMCH("T")=Y,X=$P(AMCH("D"),"-",2)
 D SBMD
 S AMCH("F")=Y,X=$P($T(IMM),";;",AMCH("G")+1)
 K AMCH("L")
 F AMCH("I")=1:1 S Y=$P(X,U,AMCH("I")) Q:Y=""  S AMCH("L",AMCH("I"))=Y
 S:AMCH("I")=3 AMCH("L",3)=AMCH("L",2),AMCH("L",2)=""
 Q
SBMD S AMCH("M")=AMCHM,Y=AMCHY
 F AMCH("I")=1:1:X S AMCH("M")=AMCH("M")-1 I AMCH("M")<1 S AMCH("M")=12,Y=Y-1
 S Y=$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",AMCH("M"))_" "_Y
 Q
CON W *7
 D SBRS^AMCHU
 S AMCHCON=0
 Q
IMM ;;DTP-1^OPV-1^HIBT-1^PVHIB-1^HEPB-1;;DTP-2^OPV-2^HIBT-2^PVHIB-2^HEPB-2;;DTP-3^OPV-3^HIBT-3^PVHIB-2^HEPB-2;;DTP-3^OPV-3^MMR^HIB^HEPB-2;;DTP-4^OPV-3^MMR^HIB^HEPB-3;;DTP-4^OPV-3^MMR^HIB^HEPB-3