APCLM2 ; IHS/CMI/LAB - ADULT IMMUNIZATION NEEDS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;IHS/CMI/LAB - patch 4 1/5/1999 for new immunization package
;
START ;
W:$D(IOF) @IOF
W !!?12,"********** CHILDREN NOT ON IMMUNIZATION REGISTER **********"
W !!,"This report will list all children in an age range that you select, who are not",!,"on the immunization register. You will be asked to specify an age range",!,"and the community or communities that you are interested in.",!!
AGE ;
W !
K APCLAGER
S DIR(0)="FO^1:7",DIR("A")="Enter an AGE Range (e.g. 5-12) [HIT RETURN TO INCLUDE ALL AGES]" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DUOUT) G XIT
I Y="" W !!,"No age range entered. All ages will be included." G COMM
I Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter an age range in the format nnn-nnn. E.g. 2-5, 12-74, 5-20." G AGE
S APCLAGER=Y
COMM ;
K APCLCOMM
S DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)",DIR("A")="List children who live in",DIR("B")="O" K DA D ^DIR K DIR
G:$D(DIRUT) AGE
I Y="A" W !!,"Kids from all communities will be included in the report.",! G ZIS
I Y="O" D G:'$D(APCLCOMM) COMM G:$D(APCLCOMM) ZIS I 1
.S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC
.Q:Y=-1
.S APCLCOMM($P(^AUTTCOM(+Y,0),U))=""
S X="COMMUNITY",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G XIT
D PEP^AMQQGTX0(+Y,"APCLCOMM(")
I '$D(APCLCOMM) G COMM
I $D(APCLCOMM("*")) K APCLCOMM
ZIS ;call to XBDBQUE
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G COMM
S XBRP="PRN^APCLM2",XBRC="PROC^APCLM2",XBRX="XIT^APCLM2",XBNS="APCL"
D ^XBDBQUE
D XIT
Q
XIT ;
K APCLAGE,APCLAGER,APCLBT,APCLCNT,APCLCOM,APCLCOMM,APCLET,APCLJOB,APCLNAME,APCLPG,APCLQUIT
K A,B,C,D,S,DA,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,H,I,K,M,N,TS,V,X,X1,X2,Y
D KILL^AUPNPAT
K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M
Q
PROC ;
S APCLBT=$H,APCLJOB=$J,APCLCNT=0
D XTMP^APCLOSUT("APCLM2","PCC IMMUNIZATION REPORT 2")
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:DFN'=+DFN D PROC1
S APCLET=$H
Q
PROC1 ;
Q:$P($G(^DPT(DFN,.35)),U)]"" ;don't include deceased patients
Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
I $O(^AUTTIMM(0))<100 Q:$D(^AMCH(85,"B",DFN)) ;skip if on MCH register (mch pt) ;IHS/CMI/LAB - changed for new imm package patch 4
I $O(^AUTTIMM(0))>99 Q:$D(^BIP("B",DFN)) ;IHS/CMI/LAB - new line for new imm package patch 4
I $D(APCLCOMM),$$COMMRES^AUPNPAT(DFN,"E")="" Q ;quit if want a particular community and patient's community is blank
I $D(APCLCOMM),'$D(APCLCOMM($$COMMRES^AUPNPAT(DFN,"E"))) Q ;quit if community selected is not this patient's community
S APCLAGE=$$AGE^AUPNPAT(DFN,DT)
I $D(APCLAGER),APCLAGE<$P(APCLAGER,"-") Q
I $D(APCLAGER),APCLAGE>$P(APCLAGER,"-",2) Q
S ^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",$S($$COMMRES^AUPNPAT(DFN,"E")=-1:"?? - UNKNOWN",$$COMMRES^AUPNPAT(DFN,"E")]"":$$COMMRES^AUPNPAT(DFN,"E"),1:"??"),$P(^DPT(DFN,0),U),DFN)=""
S APCLCNT=APCLCNT+1
Q
PRN ;EP
S APCLPG=0
I '$D(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN")) D HEAD W !!,"NO DATA TO REPORT",! G DONE
I '$D(APCLCOMM) D HEAD
K APCLQUIT
D PRINT
;
DONE ;
D DONE^APCLOSUT
Q
PRINT ;
S APCLCOM="" F S APCLCOM=$O(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",APCLCOM)) Q:APCLCOM=""!($D(APCLQUIT)) D
.I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)
.W !!,"Community: ",APCLCOM,!,$TR($J("",$L(APCLCOM)+11)," ","-"),!
.S APCLNAME="" F S APCLNAME=$O(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",APCLCOM,APCLNAME)) Q:APCLNAME=""!($D(APCLQUIT)) D
..S DFN=0 F S DFN=$O(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",APCLCOM,APCLNAME,DFN)) Q:DFN'=+DFN!($D(APCLQUIT)) D PRINT1
Q
PRINT1 ;
I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)
W !,$E($P(^DPT(DFN,0),U),1,20),?23,"(",$$HRN^AUPNPAT(DFN,DUZ(2)),")",?34,$$DOB^AUPNPAT(DFN,"E"),?50,$$RAGE($P(^DPT(DFN,0),U,3)),?66,$$VAL^XBDIQ1(2,DFN,.02),!
D GETIMM
I 'C W !?12,"No prior immunizations listed",! Q
S D=0 F S D=$O(B(D)) Q:D=""!($D(APCLQUIT)) D SBW
W !
Q
SBW ;
I $Y>(IOSL-3) D HEAD Q:$D(APCLQUIT)
W !,?16,$$FMTE^XLFDT(D),?30
S (C,N)=0 F S C=$O(B(D,C)) Q:C="" W:N ", " D
.S N=N+1,V=$P(B(D,C),U),S=$P(B(D,C),U,2)
.I V,$D(^AUTTIMM(V,0)) S V=$P(^(0),U,2) W:S S," " W V
.Q
Q
GETIMM ;
K A,B S (C,I)=0 NEW X,S,K,V,D
F S I=$O(^AUPNVIMM("AC",DFN,I)) Q:I'=+I D
.Q:'$D(^AUPNVIMM(I,0))
.S X=^AUPNVIMM(I,0),V=$P(X,U)
.S S=$P(X,U,4),K=$P(X,U,3),D=""
.I K,$D(^AUPNVSIT(K,0)) S D=+$P(^(0),".",1)
.S C=C+1,B(D,C)=V_U_S
Q
RAGE(D) ;printable age
NEW X1,X2,X,%
S X1=DT,X2=D
D ^%DTC
S %=$S(X<60:X_" Days",X<1096:$J(X/30.44,0,0)_" Months",1:$J(X\365.25,0,0)_" Years")
Q %
HEAD I 'APCLPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !?5,"WARNING: CONFIDENTIAL PATIENT INFORMATION, PRIVACY ACT APPLIES",!
W !?3,$P(^DIC(4,DUZ(2),0),U),?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG
W !?12,"******** CHILDREN NOT ON IMMUNIZATION REGISTER ********",!!
Q
APCLM2 ; IHS/CMI/LAB - ADULT IMMUNIZATION NEEDS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;IHS/CMI/LAB - patch 4 1/5/1999 for new immunization package
+4 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!?12,"********** CHILDREN NOT ON IMMUNIZATION REGISTER **********"
+3 WRITE !!,"This report will list all children in an age range that you select, who are not",!,"on the immunization register. You will be asked to specify an age range",!,"and the community or communities that you are interested in.",!!
AGE ;
+1 WRITE !
+2 KILL APCLAGER
+3 SET DIR(0)="FO^1:7"
SET DIR("A")="Enter an AGE Range (e.g. 5-12) [HIT RETURN TO INCLUDE ALL AGES]"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DUOUT)
GOTO XIT
+5 IF Y=""
WRITE !!,"No age range entered. All ages will be included."
GOTO COMM
+6 IF Y'?1.3N1"-"1.3N
WRITE !!,$CHAR(7),$CHAR(7),"Enter an age range in the format nnn-nnn. E.g. 2-5, 12-74, 5-20."
GOTO AGE
+7 SET APCLAGER=Y
COMM ;
+1 KILL APCLCOMM
+2 SET DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)"
SET DIR("A")="List children who live in"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO AGE
+4 IF Y="A"
WRITE !!,"Kids from all communities will be included in the report.",!
GOTO ZIS
+5 IF Y="O"
Begin DoDot:1
+6 SET DIC="^AUTTCOM("
SET DIC(0)="AEMQ"
SET DIC("A")="Which COMMUNITY: "
DO ^DIC
KILL DIC
+7 IF Y=-1
QUIT
+8 SET APCLCOMM($PIECE(^AUTTCOM(+Y,0),U))=""
End DoDot:1
IF '$DATA(APCLCOMM)
GOTO COMM
IF $DATA(APCLCOMM)
GOTO ZIS
IF 1
+9 SET X="COMMUNITY"
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
GOTO XIT
+10 DO PEP^AMQQGTX0(+Y,"APCLCOMM(")
+11 IF '$DATA(APCLCOMM)
GOTO COMM
+12 IF $DATA(APCLCOMM("*"))
KILL APCLCOMM
ZIS ;call to XBDBQUE
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO COMM
+3 SET XBRP="PRN^APCLM2"
SET XBRC="PROC^APCLM2"
SET XBRX="XIT^APCLM2"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 DO XIT
+6 QUIT
XIT ;
+1 KILL APCLAGE,APCLAGER,APCLBT,APCLCNT,APCLCOM,APCLCOMM,APCLET,APCLJOB,APCLNAME,APCLPG,APCLQUIT
+2 KILL A,B,C,D,S,DA,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,H,I,K,M,N,TS,V,X,X1,X2,Y
+3 DO KILL^AUPNPAT
+4 KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M
+5 QUIT
PROC ;
+1 SET APCLBT=$HOROLOG
SET APCLJOB=$JOB
SET APCLCNT=0
+2 DO XTMP^APCLOSUT("APCLM2","PCC IMMUNIZATION REPORT 2")
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
IF DFN'=+DFN
QUIT
DO PROC1
+4 SET APCLET=$HOROLOG
+5 QUIT
PROC1 ;
+1 ;don't include deceased patients
IF $PIECE($GET(^DPT(DFN,.35)),U)]""
QUIT
+2 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+3 ;skip if on MCH register (mch pt) ;IHS/CMI/LAB - changed for new imm package patch 4
IF $ORDER(^AUTTIMM(0))<100
IF $DATA(^AMCH(85,"B",DFN))
QUIT
+4 ;IHS/CMI/LAB - new line for new imm package patch 4
IF $ORDER(^AUTTIMM(0))>99
IF $DATA(^BIP("B",DFN))
QUIT
+5 ;quit if want a particular community and patient's community is blank
IF $DATA(APCLCOMM)
IF $$COMMRES^AUPNPAT(DFN,"E")=""
QUIT
+6 ;quit if community selected is not this patient's community
IF $DATA(APCLCOMM)
IF '$DATA(APCLCOMM($$COMMRES^AUPNPAT(DFN,"E")))
QUIT
+7 SET APCLAGE=$$AGE^AUPNPAT(DFN,DT)
+8 IF $DATA(APCLAGER)
IF APCLAGE<$PIECE(APCLAGER,"-")
QUIT
+9 IF $DATA(APCLAGER)
IF APCLAGE>$PIECE(APCLAGER,"-",2)
QUIT
+10 SET ^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",$SELECT($$COMMRES^AUPNPAT(DFN,"E")=-1:"?? - UNKNOWN",$$COMMRES^AUPNPAT(DFN,"E")]"":$$COMMRES^AUPNPAT(DFN,"E"),1:"??"),$PIECE(^DPT(DFN,0),U),DFN)=""
+11 SET APCLCNT=APCLCNT+1
+12 QUIT
PRN ;EP
+1 SET APCLPG=0
+2 IF '$DATA(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN"))
DO HEAD
WRITE !!,"NO DATA TO REPORT",!
GOTO DONE
+3 IF '$DATA(APCLCOMM)
DO HEAD
+4 KILL APCLQUIT
+5 DO PRINT
+6 ;
DONE ;
+1 DO DONE^APCLOSUT
+2 QUIT
PRINT ;
+1 SET APCLCOM=""
FOR
SET APCLCOM=$ORDER(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",APCLCOM))
IF APCLCOM=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+3 WRITE !!,"Community: ",APCLCOM,!,$TRANSLATE($JUSTIFY("",$LENGTH(APCLCOM)+11)," ","-"),!
+4 SET APCLNAME=""
FOR
SET APCLNAME=$ORDER(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",APCLCOM,APCLNAME))
IF APCLNAME=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:2
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLM2",APCLJOB,APCLBT,"CHILDREN",APCLCOM,APCLNAME,DFN))
IF DFN'=+DFN!($DATA(APCLQUIT))
QUIT
DO PRINT1
End DoDot:2
End DoDot:1
+6 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?23,"(",$$HRN^AUPNPAT(DFN,DUZ(2)),")",?34,$$DOB^AUPNPAT(DFN,"E"),?50,$$RAGE($PIECE(^DPT(DFN,0),U,3)),?66,$$VAL^XBDIQ1(2,DFN,.02),!
+3 DO GETIMM
+4 IF 'C
WRITE !?12,"No prior immunizations listed",!
QUIT
+5 SET D=0
FOR
SET D=$ORDER(B(D))
IF D=""!($DATA(APCLQUIT))
QUIT
DO SBW
+6 WRITE !
+7 QUIT
SBW ;
+1 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !,?16,$$FMTE^XLFDT(D),?30
+3 SET (C,N)=0
FOR
SET C=$ORDER(B(D,C))
IF C=""
QUIT
IF N
WRITE ", "
Begin DoDot:1
+4 SET N=N+1
SET V=$PIECE(B(D,C),U)
SET S=$PIECE(B(D,C),U,2)
+5 IF V
IF $DATA(^AUTTIMM(V,0))
SET V=$PIECE(^(0),U,2)
IF S
WRITE S," "
WRITE V
+6 QUIT
End DoDot:1
+7 QUIT
GETIMM ;
+1 KILL A,B
SET (C,I)=0
NEW X,S,K,V,D
+2 FOR
SET I=$ORDER(^AUPNVIMM("AC",DFN,I))
IF I'=+I
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVIMM(I,0))
QUIT
+4 SET X=^AUPNVIMM(I,0)
SET V=$PIECE(X,U)
+5 SET S=$PIECE(X,U,4)
SET K=$PIECE(X,U,3)
SET D=""
+6 IF K
IF $DATA(^AUPNVSIT(K,0))
SET D=+$PIECE(^(0),".",1)
+7 SET C=C+1
SET B(D,C)=V_U_S
End DoDot:1
+8 QUIT
RAGE(D) ;printable age
+1 NEW X1,X2,X,%
+2 SET X1=DT
SET X2=D
+3 DO ^%DTC
+4 SET %=$SELECT(X<60:X_" Days",X<1096:$JUSTIFY(X/30.44,0,0)_" Months",1:$JUSTIFY(X\365.25,0,0)_" Years")
+5 QUIT %
HEAD IF 'APCLPG
GOTO HEAD1
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !?5,"WARNING: CONFIDENTIAL PATIENT INFORMATION, PRIVACY ACT APPLIES",!
+3 WRITE !?3,$PIECE(^DIC(4,DUZ(2),0),U),?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG
+4 WRITE !?12,"******** CHILDREN NOT ON IMMUNIZATION REGISTER ********",!!
+5 QUIT
