APCHS5 ; IHS/CMI/LAB - PART 5 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**6,7,11**;MAY 14, 2009;Build 58
;
INS ; ******************* INSURANCE * 9000003, 9000004, 9000006 *********
I $O(^AUPNMCD("B",APCHSPAT,0))="",'$D(^AUPNMCR(APCHSPAT)),'$D(^AUPNPRVT(APCHSPAT)),'$D(^AUPNRRE(APCHSPAT)) Q
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
W "INSURANCE",?32,"NUMBER",?44,"SUFF",?49,"COV",?54,"EL DATE",?63,"SIG DATE",?72,"END DATE",!
D MAID^APCHS5A,MCARE^APCHS5A,THIRD^APCHS5A,RR^APCHS5A
INSX K APCHSPDN,APCHSINS,APCHSEDN,APCHSN,APCHSIDN,APCHSDTL,APCHSDTN,APCHSUFF,APCHSCOV,APCHSDTS,APCHSI,APCHSJ,APCHSITB
Q
;
ELDER1 ;
I '$D(^AUPNVELD("AA",APCHSPAT)) Q
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
W "ADL",!
F APCHSY=.04,.05,.06,.07,.08,.09 Q:$D(APCHSQIT) S APCHSP=+$P(APCHSY,".",2),APCHSN=$P(^DD(9000010.35,APCHSY,0),U) D VAL(APCHSPAT,APCHSY,APCHSP,1) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?2,APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
.Q
W !,"IADL",!
F APCHSY=.11,.12,.13,.14,.15,.16 Q:$D(APCHSQIT) S APCHSP=+$P(APCHSY,".",2),APCHSN=$P(^DD(9000010.35,APCHSY,0),U) D VAL(APCHSPAT,APCHSY,APCHSP,1) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?2,APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
.Q
S APCHSN="CHANGE IN FUNCTIONAL STATUS",APCHSP=17,APCHSY=.17 D VAL(APCHSPAT,APCHSY,APCHSP,1)
X APCHSCKP Q:$D(APCHSQIT)
W !,APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
;X APCHSCKP Q:$D(APCHSQIT)
;S APCHSN="PATIENT A CAREGIVER?",APCHSP=18,APCHSY=.18 D VAL(APCHSPAT,APCHSY,APCHSP,1)
;W APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
Q
;
ELDER2 ;elder care last 2 of each
I '$D(^AUPNVELD("AA",APCHSPAT)) Q
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
W "ADL",!
F APCHSY=.04,.05,.06,.07,.08,.09 Q:$D(APCHSQIT) S APCHSP=+$P(APCHSY,".",2),APCHSN=$P(^DD(9000010.35,APCHSY,0),U) D VAL(APCHSPAT,APCHSY,APCHSP,2) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?2,APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
.X APCHSCKP Q:$D(APCHSQIT)
.I $G(APCHSX(2))]"" W ?28,$$D($P($G(APCHSX(2)),U)),?40,$P($G(APCHSX(2)),U,2),!
.Q
W !,"IADL",!
F APCHSY=.11,.12,.13,.14,.15,.16 Q:$D(APCHSQIT) S APCHSP=+$P(APCHSY,".",2),APCHSN=$P(^DD(9000010.35,APCHSY,0),U) D VAL(APCHSPAT,APCHSY,APCHSP,2) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?2,APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
.X APCHSCKP Q:$D(APCHSQIT)
.I $G(APCHSX(2))]"" W ?28,$$D($P($G(APCHSX(2)),U)),?40,$P($G(APCHSX(2)),U,2),!
.Q
S APCHSN="CHANGE IN FUNCTIONAL STATUS",APCHSP=17,APCHSY=.17 D VAL(APCHSPAT,APCHSY,APCHSP,2)
X APCHSCKP Q:$D(APCHSQIT)
W !,APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
X APCHSCKP Q:$D(APCHSQIT)
I $G(APCHSX(2))]"" W ?28,$$D($P($G(APCHSX(2)),U)),?40,$P($G(APCHSX(2)),U,2),!
X APCHSCKP Q:$D(APCHSQIT)
;S APCHSN="PATIENT A CAREGIVER?",APCHSP=18,APCHSY=.18 D VAL(APCHSPAT,APCHSY,APCHSP,2)
;X APCHSCKP Q:$D(APCHSQIT)
;W APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
;X APCHSCKP Q:$D(APCHSQIT)
;I $G(APCHSX(2))]"" W ?28,$$D($P($G(APCHSX(2)),U)),?40,$P($G(APCHSX(2)),U,2),!
Q
;
D(X) ;
I $G(X)="" Q ""
Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
VAL(P,F,V,I) ;
K APCHSX
NEW % F %=1:1:I S APCHSX(%)=""
NEW C S C=0
NEW X,Y
S X=0 F S X=$O(^AUPNVELD("AA",P,X)) Q:X=""!(C>I) S Y=0 F S Y=$O(^AUPNVELD("AA",P,X,Y)) Q:Y=""!(C>I) I $P(^AUPNVELD(Y,0),U,V)]"" S C=C+1,APCHSX(C)=9999999-X_"^"_$$VAL^XBDIQ1(9000010.35,Y,F)
Q
REFUSAL ;EP - refusal component
;Q:'$D(^AUPNPREF("AA",APCHSPAT)) ;no refusals on file
;gather any refusals from Immuniztion package
K APCHSX
S Y=0 F S Y=$O(^BIPC("AC",APCHSPAT,Y)) Q:Y'=+Y D
.S X=0 F S X=$O(^BIPC("AC",APCHSPAT,Y,X)) Q:X'=+X D
..S R=$P(^BIPC(X,0),U,3)
..Q:R=""
..Q:'$D(^BICONT(R,0))
..Q:$P(^BICONT(R,0),U,1)'["Refusal"
..S D=$P(^BIPC(X,0),U,4)
..Q:D=""
..S D=9999999-D
..Q:D>APCHSDLM
..S APCHSX(D,"IMM",X)=""
I '$D(^AUPNPREF("AA",APCHSPAT)),'$D(APCHSX) Q ;no refusals
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
NEW X,F,I,D,E
S F=0 F S F=$O(^AUPNPREF("AA",APCHSPAT,F)) Q:F'=+F D
.S E=0 F S E=$O(^AUPNPREF("AA",APCHSPAT,F,E)) Q:E'=+E D
..S D=0 F S D=$O(^AUPNPREF("AA",APCHSPAT,F,E,D)) Q:D'=+D!(D>APCHSDLM) D
...S I=0 F S I=$O(^AUPNPREF("AA",APCHSPAT,F,E,D,I)) Q:I'=+I S APCHSX(D,"REF",I)=""
NEW APCHSD,APCHSI S APCHSD=0 F S APCHSD=$O(APCHSX(APCHSD)) Q:APCHSD'=+APCHSD!($D(APCHSQIT)) D
.S APCHSI=0 F S APCHSI=$O(APCHSX(APCHSD,"REF",APCHSI)) Q:APCHSI'=+APCHSI!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W ?3,$$FMTE^XLFDT(9999999-APCHSD),?17,$$VAL^XBDIQ1(9000022,APCHSI,.04),! ;" (",$$VAL^XBDIQ1(9000022,APCHSI,.01),")",!
..W ?5,"Reason not Done: ",$$REFR^AUPNVUTL(APCHSI),!
..I $P($G(^AUPNPREF(APCHSI,11)),U,1)]"",$P(^APCHSCTL(APCHSTYP,0),U,8) D
...;display comments using DIWP
...K ^UTILITY($J,"W")
...S X="Comments: "_$P(^AUPNPREF(APCHSI,11),U,1)
...S DIWL=0,DIWR=74
...D ^DIWP
...S APCHSZ=0 F S APCHSZ=$O(^UTILITY($J,"W",DIWL,APCHSZ)) Q:APCHSZ'=+APCHSZ!($D(APCHSQIT)) D
....X APCHSCKP Q:$D(APCHSQIT)
....W ?5,^UTILITY($J,"W",DIWL,APCHSZ,0),!
...K ^UTILITY($J,"W")
.S APCHSI=0 F S APCHSI=$O(APCHSX(APCHSD,"IMM",APCHSI)) Q:APCHSI'=+APCHSI!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W ?3,$$FMTE^XLFDT(9999999-APCHSD),?17,$$VAL^XBDIQ1(9002084.11,APCHSI,.02),!
..W ?5,"Reason not Done: ",$$VAL^XBDIQ1(9002084.11,APCHSI,.03),!
Q
LER ;refusal component
;Q:'$D(^AUPNPREF("AA",APCHSPAT)) ;no refusals on file
;gather any refusals from Immuniztion package
K APCHSX
S Y=0 F S Y=$O(^BIPC("AC",APCHSPAT,Y)) Q:Y'=+Y D
.S X=0 F S X=$O(^BIPC("AC",APCHSPAT,Y,X)) Q:X'=+X D
..S R=$P(^BIPC(X,0),U,3)
..Q:R=""
..Q:'$D(^BICONT(R,0))
..Q:$P(^BICONT(R,0),U,1)'["Refusal"
..S D=$P(^BIPC(X,0),U,4)
..Q:D=""
..S D=9999999-D
..Q:D>APCHSDLM
..S APCHSX("REF","IMMUNIZATION",$$VAL^XBDIQ1(9002084.11,X,.02),D)=X_U_$$VAL^XBDIQ1(9002084.11,X,.03)
I '$D(^AUPNPREF("AA",APCHSPAT)),'$D(APCHSX) Q ;no refusals
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
NEW X,F,I,D,E
S F=0 F S F=$O(^AUPNPREF("AA",APCHSPAT,F)) Q:F'=+F D
.S E=0 F S E=$O(^AUPNPREF("AA",APCHSPAT,F,E)) Q:E'=+E D
..S D=0 F S D=$O(^AUPNPREF("AA",APCHSPAT,F,E,D)) Q:D'=+D!(D>APCHSDLM) D
...S I=0 F S I=$O(^AUPNPREF("AA",APCHSPAT,F,E,D,I)) Q:I'=+I D
....S APCHSX("REF",$S($$VAL^XBDIQ1(9000022,I,.05)]"":$$VAL^XBDIQ1(9000022,I,.05),1:"NOT ENTERED"),$S($$VAL^XBDIQ1(9000022,I,.04)]"":$$VAL^XBDIQ1(9000022,I,.04),1:"NOT ENTERED"),D)=I_U_$$REFR^AUPNVUTL(I)
NEW APCHSD,APCHSI S APCHSC="" F S APCHSC=$O(APCHSX("REF",APCHSC)) Q:APCHSC=""!($D(APCHSQIT)) D
.S APCHSI="" F S APCHSI=$O(APCHSX("REF",APCHSC,APCHSI)) Q:APCHSI=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..S APCHSD=$O(APCHSX("REF",APCHSC,APCHSI,0))
..S APCHSDA=$P(APCHSX("REF",APCHSC,APCHSI,APCHSD),U)
..S APCHSRT=$P(APCHSX("REF",APCHSC,APCHSI,APCHSD),U,2)
..W ?3,$E(APCHSI,1,30),?65,$$FMTE^XLFDT(9999999-APCHSD,5),!
..W ?5,"Reason not Done: ",APCHSRT,!
..I $P($G(^AUPNPREF(APCHSDA,11)),U,1)]"",$P(^APCHSCTL(APCHSTYP,0),U,8) D
...;display comments using DIWP
...K ^UTILITY($J,"W")
...S X="Comments: "_$P(^AUPNPREF(APCHSDA,11),U,1)
...S DIWL=0,DIWR=74
...D ^DIWP
...S APCHSZ=0 F S APCHSZ=$O(^UTILITY($J,"W",DIWL,APCHSZ)) Q:APCHSZ'=+APCHSZ!($D(APCHSQIT)) D
....X APCHSCKP Q:$D(APCHSQIT)
....W ?5,^UTILITY($J,"W",DIWL,APCHSZ,0),!
...K ^UTILITY($J,"W")
Q
APCHS5 ; IHS/CMI/LAB - PART 5 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**6,7,11**;MAY 14, 2009;Build 58
+2 ;
INS ; ******************* INSURANCE * 9000003, 9000004, 9000006 *********
+1 IF $ORDER(^AUPNMCD("B",APCHSPAT,0))=""
IF '$DATA(^AUPNMCR(APCHSPAT))
IF '$DATA(^AUPNPRVT(APCHSPAT))
IF '$DATA(^AUPNRRE(APCHSPAT))
QUIT
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+3 WRITE "INSURANCE",?32,"NUMBER",?44,"SUFF",?49,"COV",?54,"EL DATE",?63,"SIG DATE",?72,"END DATE",!
+4 DO MAID^APCHS5A
DO MCARE^APCHS5A
DO THIRD^APCHS5A
DO RR^APCHS5A
INSX KILL APCHSPDN,APCHSINS,APCHSEDN,APCHSN,APCHSIDN,APCHSDTL,APCHSDTN,APCHSUFF,APCHSCOV,APCHSDTS,APCHSI,APCHSJ,APCHSITB
+1 QUIT
+2 ;
ELDER1 ;
+1 IF '$DATA(^AUPNVELD("AA",APCHSPAT))
QUIT
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+3 WRITE "ADL",!
+4 FOR APCHSY=.04,.05,.06,.07,.08,.09
IF $DATA(APCHSQIT)
QUIT
SET APCHSP=+$PIECE(APCHSY,".",2)
SET APCHSN=$PIECE(^DD(9000010.35,APCHSY,0),U)
DO VAL(APCHSPAT,APCHSY,APCHSP,1)
Begin DoDot:1
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 WRITE ?2,APCHSN,?28,$$D($PIECE($GET(APCHSX(1)),U)),?40,$PIECE($GET(APCHSX(1)),U,2),!
+7 QUIT
End DoDot:1
+8 WRITE !,"IADL",!
+9 FOR APCHSY=.11,.12,.13,.14,.15,.16
IF $DATA(APCHSQIT)
QUIT
SET APCHSP=+$PIECE(APCHSY,".",2)
SET APCHSN=$PIECE(^DD(9000010.35,APCHSY,0),U)
DO VAL(APCHSPAT,APCHSY,APCHSP,1)
Begin DoDot:1
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 WRITE ?2,APCHSN,?28,$$D($PIECE($GET(APCHSX(1)),U)),?40,$PIECE($GET(APCHSX(1)),U,2),!
+12 QUIT
End DoDot:1
+13 SET APCHSN="CHANGE IN FUNCTIONAL STATUS"
SET APCHSP=17
SET APCHSY=.17
DO VAL(APCHSPAT,APCHSY,APCHSP,1)
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 WRITE !,APCHSN,?28,$$D($PIECE($GET(APCHSX(1)),U)),?40,$PIECE($GET(APCHSX(1)),U,2),!
+16 ;X APCHSCKP Q:$D(APCHSQIT)
+17 ;S APCHSN="PATIENT A CAREGIVER?",APCHSP=18,APCHSY=.18 D VAL(APCHSPAT,APCHSY,APCHSP,1)
+18 ;W APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
+19 QUIT
+20 ;
ELDER2 ;elder care last 2 of each
+1 IF '$DATA(^AUPNVELD("AA",APCHSPAT))
QUIT
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+3 WRITE "ADL",!
+4 FOR APCHSY=.04,.05,.06,.07,.08,.09
IF $DATA(APCHSQIT)
QUIT
SET APCHSP=+$PIECE(APCHSY,".",2)
SET APCHSN=$PIECE(^DD(9000010.35,APCHSY,0),U)
DO VAL(APCHSPAT,APCHSY,APCHSP,2)
Begin DoDot:1
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 WRITE ?2,APCHSN,?28,$$D($PIECE($GET(APCHSX(1)),U)),?40,$PIECE($GET(APCHSX(1)),U,2),!
+7 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+8 IF $GET(APCHSX(2))]""
WRITE ?28,$$D($PIECE($GET(APCHSX(2)),U)),?40,$PIECE($GET(APCHSX(2)),U,2),!
+9 QUIT
End DoDot:1
+10 WRITE !,"IADL",!
+11 FOR APCHSY=.11,.12,.13,.14,.15,.16
IF $DATA(APCHSQIT)
QUIT
SET APCHSP=+$PIECE(APCHSY,".",2)
SET APCHSN=$PIECE(^DD(9000010.35,APCHSY,0),U)
DO VAL(APCHSPAT,APCHSY,APCHSP,2)
Begin DoDot:1
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 WRITE ?2,APCHSN,?28,$$D($PIECE($GET(APCHSX(1)),U)),?40,$PIECE($GET(APCHSX(1)),U,2),!
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 IF $GET(APCHSX(2))]""
WRITE ?28,$$D($PIECE($GET(APCHSX(2)),U)),?40,$PIECE($GET(APCHSX(2)),U,2),!
+16 QUIT
End DoDot:1
+17 SET APCHSN="CHANGE IN FUNCTIONAL STATUS"
SET APCHSP=17
SET APCHSY=.17
DO VAL(APCHSPAT,APCHSY,APCHSP,2)
+18 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+19 WRITE !,APCHSN,?28,$$D($PIECE($GET(APCHSX(1)),U)),?40,$PIECE($GET(APCHSX(1)),U,2),!
+20 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+21 IF $GET(APCHSX(2))]""
WRITE ?28,$$D($PIECE($GET(APCHSX(2)),U)),?40,$PIECE($GET(APCHSX(2)),U,2),!
+22 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+23 ;S APCHSN="PATIENT A CAREGIVER?",APCHSP=18,APCHSY=.18 D VAL(APCHSPAT,APCHSY,APCHSP,2)
+24 ;X APCHSCKP Q:$D(APCHSQIT)
+25 ;W APCHSN,?28,$$D($P($G(APCHSX(1)),U)),?40,$P($G(APCHSX(1)),U,2),!
+26 ;X APCHSCKP Q:$D(APCHSQIT)
+27 ;I $G(APCHSX(2))]"" W ?28,$$D($P($G(APCHSX(2)),U)),?40,$P($G(APCHSX(2)),U,2),!
+28 QUIT
+29 ;
D(X) ;
+1 IF $GET(X)=""
QUIT ""
+2 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
VAL(P,F,V,I) ;
+1 KILL APCHSX
+2 NEW %
FOR %=1:1:I
SET APCHSX(%)=""
+3 NEW C
SET C=0
+4 NEW X,Y
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVELD("AA",P,X))
IF X=""!(C>I)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNVELD("AA",P,X,Y))
IF Y=""!(C>I)
QUIT
IF $PIECE(^AUPNVELD(Y,0),U,V)]""
SET C=C+1
SET APCHSX(C)=9999999-X_"^"_$$VAL^XBDIQ1(9000010.35,Y,F)
+6 QUIT
REFUSAL ;EP - refusal component
+1 ;Q:'$D(^AUPNPREF("AA",APCHSPAT)) ;no refusals on file
+2 ;gather any refusals from Immuniztion package
+3 KILL APCHSX
+4 SET Y=0
FOR
SET Y=$ORDER(^BIPC("AC",APCHSPAT,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^BIPC("AC",APCHSPAT,Y,X))
IF X'=+X
QUIT
Begin DoDot:2
+6 SET R=$PIECE(^BIPC(X,0),U,3)
+7 IF R=""
QUIT
+8 IF '$DATA(^BICONT(R,0))
QUIT
+9 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+10 SET D=$PIECE(^BIPC(X,0),U,4)
+11 IF D=""
QUIT
+12 SET D=9999999-D
+13 IF D>APCHSDLM
QUIT
+14 SET APCHSX(D,"IMM",X)=""
End DoDot:2
End DoDot:1
+15 ;no refusals
IF '$DATA(^AUPNPREF("AA",APCHSPAT))
IF '$DATA(APCHSX)
QUIT
+16 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+17 NEW X,F,I,D,E
+18 SET F=0
FOR
SET F=$ORDER(^AUPNPREF("AA",APCHSPAT,F))
IF F'=+F
QUIT
Begin DoDot:1
+19 SET E=0
FOR
SET E=$ORDER(^AUPNPREF("AA",APCHSPAT,F,E))
IF E'=+E
QUIT
Begin DoDot:2
+20 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",APCHSPAT,F,E,D))
IF D'=+D!(D>APCHSDLM)
QUIT
Begin DoDot:3
+21 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",APCHSPAT,F,E,D,I))
IF I'=+I
QUIT
SET APCHSX(D,"REF",I)=""
End DoDot:3
End DoDot:2
End DoDot:1
+22 NEW APCHSD,APCHSI
SET APCHSD=0
FOR
SET APCHSD=$ORDER(APCHSX(APCHSD))
IF APCHSD'=+APCHSD!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+23 SET APCHSI=0
FOR
SET APCHSI=$ORDER(APCHSX(APCHSD,"REF",APCHSI))
IF APCHSI'=+APCHSI!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+24 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+25 ;" (",$$VAL^XBDIQ1(9000022,APCHSI,.01),")",!
WRITE ?3,$$FMTE^XLFDT(9999999-APCHSD),?17,$$VAL^XBDIQ1(9000022,APCHSI,.04),!
+26 WRITE ?5,"Reason not Done: ",$$REFR^AUPNVUTL(APCHSI),!
+27 IF $PIECE($GET(^AUPNPREF(APCHSI,11)),U,1)]""
IF $PIECE(^APCHSCTL(APCHSTYP,0),U,8)
Begin DoDot:3
+28 ;display comments using DIWP
+29 KILL ^UTILITY($JOB,"W")
+30 SET X="Comments: "_$PIECE(^AUPNPREF(APCHSI,11),U,1)
+31 SET DIWL=0
SET DIWR=74
+32 DO ^DIWP
+33 SET APCHSZ=0
FOR
SET APCHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCHSZ))
IF APCHSZ'=+APCHSZ!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+34 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+35 WRITE ?5,^UTILITY($JOB,"W",DIWL,APCHSZ,0),!
End DoDot:4
+36 KILL ^UTILITY($JOB,"W")
End DoDot:3
End DoDot:2
+37 SET APCHSI=0
FOR
SET APCHSI=$ORDER(APCHSX(APCHSD,"IMM",APCHSI))
IF APCHSI'=+APCHSI!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+38 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+39 WRITE ?3,$$FMTE^XLFDT(9999999-APCHSD),?17,$$VAL^XBDIQ1(9002084.11,APCHSI,.02),!
+40 WRITE ?5,"Reason not Done: ",$$VAL^XBDIQ1(9002084.11,APCHSI,.03),!
End DoDot:2
End DoDot:1
+41 QUIT
LER ;refusal component
+1 ;Q:'$D(^AUPNPREF("AA",APCHSPAT)) ;no refusals on file
+2 ;gather any refusals from Immuniztion package
+3 KILL APCHSX
+4 SET Y=0
FOR
SET Y=$ORDER(^BIPC("AC",APCHSPAT,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^BIPC("AC",APCHSPAT,Y,X))
IF X'=+X
QUIT
Begin DoDot:2
+6 SET R=$PIECE(^BIPC(X,0),U,3)
+7 IF R=""
QUIT
+8 IF '$DATA(^BICONT(R,0))
QUIT
+9 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+10 SET D=$PIECE(^BIPC(X,0),U,4)
+11 IF D=""
QUIT
+12 SET D=9999999-D
+13 IF D>APCHSDLM
QUIT
+14 SET APCHSX("REF","IMMUNIZATION",$$VAL^XBDIQ1(9002084.11,X,.02),D)=X_U_$$VAL^XBDIQ1(9002084.11,X,.03)
End DoDot:2
End DoDot:1
+15 ;no refusals
IF '$DATA(^AUPNPREF("AA",APCHSPAT))
IF '$DATA(APCHSX)
QUIT
+16 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+17 NEW X,F,I,D,E
+18 SET F=0
FOR
SET F=$ORDER(^AUPNPREF("AA",APCHSPAT,F))
IF F'=+F
QUIT
Begin DoDot:1
+19 SET E=0
FOR
SET E=$ORDER(^AUPNPREF("AA",APCHSPAT,F,E))
IF E'=+E
QUIT
Begin DoDot:2
+20 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",APCHSPAT,F,E,D))
IF D'=+D!(D>APCHSDLM)
QUIT
Begin DoDot:3
+21 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",APCHSPAT,F,E,D,I))
IF I'=+I
QUIT
Begin DoDot:4
+22 SET APCHSX("REF",$SELECT($$VAL^XBDIQ1(9000022,I,.05)]"":$$VAL^XBDIQ1(9000022,I,.05),1:"NOT ENTERED"),$SELECT($$VAL^XBDIQ1(9000022,I,.04)]"":$$VAL^XBDIQ1(9000022,I,.04),1:"NOT ENTERED"),D)=I_U_$$REFR^AUPNVUTL(I)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 NEW APCHSD,APCHSI
SET APCHSC=""
FOR
SET APCHSC=$ORDER(APCHSX("REF",APCHSC))
IF APCHSC=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+24 SET APCHSI=""
FOR
SET APCHSI=$ORDER(APCHSX("REF",APCHSC,APCHSI))
IF APCHSI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+25 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+26 SET APCHSD=$ORDER(APCHSX("REF",APCHSC,APCHSI,0))
+27 SET APCHSDA=$PIECE(APCHSX("REF",APCHSC,APCHSI,APCHSD),U)
+28 SET APCHSRT=$PIECE(APCHSX("REF",APCHSC,APCHSI,APCHSD),U,2)
+29 WRITE ?3,$EXTRACT(APCHSI,1,30),?65,$$FMTE^XLFDT(9999999-APCHSD,5),!
+30 WRITE ?5,"Reason not Done: ",APCHSRT,!
+31 IF $PIECE($GET(^AUPNPREF(APCHSDA,11)),U,1)]""
IF $PIECE(^APCHSCTL(APCHSTYP,0),U,8)
Begin DoDot:3
+32 ;display comments using DIWP
+33 KILL ^UTILITY($JOB,"W")
+34 SET X="Comments: "_$PIECE(^AUPNPREF(APCHSDA,11),U,1)
+35 SET DIWL=0
SET DIWR=74
+36 DO ^DIWP
+37 SET APCHSZ=0
FOR
SET APCHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCHSZ))
IF APCHSZ'=+APCHSZ!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+38 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+39 WRITE ?5,^UTILITY($JOB,"W",DIWL,APCHSZ,0),!
End DoDot:4
+40 KILL ^UTILITY($JOB,"W")
End DoDot:3
End DoDot:2
End DoDot:1
+41 QUIT
