- 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
