BHSHS3 ;IHS/CIA/MGH - Health Summary for other components ;06-Aug-2018 15:44;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**2,8,15**;March 17, 2006;Build 8
;===================================================================
;VA health summary components for insurance, elder care, and refusals
;Patch 8 added SNOMED reasons for refusal
; IHS/TUCSON/LAB - PART 5 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;**5,6,8,11**;JUN 24, 1997
;Patch 2 for changes in patch 16
;Patch 15 -changes for insurance
INS ; ******************* INSURANCE * 9000003, 9000004, 9000006 *********
N BHSPAT
S BHSPAT=DFN
I $O(^AUPNMCD("B",BHSPAT,0))="",'$D(^AUPNMCR(BHSPAT)),'$D(^AUPNPRVT(BHSPAT)),'$D(^AUPNRRE(BHSPAT)) Q
D CKP^GMTSUP Q:$D(GMTSQIT)
W "INSURANCE",?25,"NUMBER",?40,"COV",?48,"EL DATE",?59,"SIG DATE",?70,"END DATE",!
D MAID^BHSINSUR,MCARE^BHSINSUR,THIRD^BHSINSUR,RR^BHSINSUR
INSX K BHSSPDN,BHSSINS,BHSSEDN,BHSSN,BHSSIDN,BHSSDTL,BHSSDTN,BHSSUFF,BHSSCOV,BHSSDTS,BHSSI,BHSSJ,BHSSITB
Q
;
;
ELDER1 ;******************** ELDER CARE 1 * 9000010.35
;----------------------------------------------------------------
N BHSPAT,BHSSP,BHSSY
S BHSPAT=DFN
I '$D(^AUPNVELD("AA",BHSPAT)) Q
D CKP^GMTSUP Q:$D(GMTSQIT)
W "ADL",!
F BHSSY=.04,.05,.06,.07,.08,.09 Q:$D(GMTSQIT) S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,1) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
.Q
W !,"IADL",!
F BHSSY=.11,.12,.13,.14,.15,.16 Q:$D(GMTSQIT) S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,1) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
.Q
S BHSSN="CHANGE IN FUNCTIONAL STATUS",BHSSP=17,BHSSY=.17 D VAL(BHSPAT,BHSSY,BHSSP,1)
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
Q
;
ELDER2 ;*********************elder care last 2 of each * 9000010.35
N BHSPAT,BHSSP,BHSSY
S BHSPAT=DFN
I '$D(^AUPNVELD("AA",BHSPAT)) Q
D CKP^GMTSUP Q:$D(GMTSQIT)
W "ADL",!
F BHSSY=.04,.05,.06,.07,.08,.09 Q:$D(GMTSQIT) S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,2) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
.D CKP^GMTSUP Q:$D(GMTSQIT)
.I $G(BHSSX(2))]"" W ?28,$$D($P($G(BHSSX(2)),U)),?40,$P($G(BHSSX(2)),U,2),!
.Q
W !,"IADL",!
F BHSSY=.11,.12,.13,.14,.15,.16 Q:$D(GMTSQIT) S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,2) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
.D CKP^GMTSUP Q:$D(GMTSQIT)
.I $G(BHSSX(2))]"" W ?28,$$D($P($G(BHSSX(2)),U)),?40,$P($G(BHSSX(2)),U,2),!
.Q
S BHSSN="CHANGE IN FUNCTIONAL STATUS",BHSSP=17,BHSSY=.17 D VAL(BHSPAT,BHSSY,BHSSP,2)
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $G(BHSSX(2))]"" W ?28,$$D($P($G(BHSSX(2)),U)),?40,$P($G(BHSSX(2)),U,2),!
D CKP^GMTSUP Q:$D(GMTSQIT)
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 BHSSX
NEW % F %=1:1:I S BHSSX(%)=""
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,BHSSX(C)=9999999-X_"^"_$$VAL^XBDIQ1(9000010.35,Y,F)
Q
;-------------------------------------------------------------------
REFUSAL ;refusal component
;--------------------------------------------------------------------
N BHSPAT,Y,X,R,D,BHSSX
S BHSPAT=DFN
;gather any refuals from Immunization package
K BHSSX
S Y=0 F S Y=$O(^BIPC("AC",BHSPAT,Y)) Q:Y'=+Y D
.S X=0 F S X=$O(^BIPC("AC",BHSPAT,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>GMTSDLM
..S BHSSX(D,"IMM",X)=""
I '$D(^AUPNPREF("AA",BHSPAT)),'$D(BHSSX) Q ;no refusals
D CKP^GMTSUP Q:$D(GMTSQIT)
NEW X,F,I,D,E
S F=0 F S F=$O(^AUPNPREF("AA",BHSPAT,F)) Q:F'=+F D
.S E=0 F S E=$O(^AUPNPREF("AA",BHSPAT,F,E)) Q:E'=+E D
..S D=0 F S D=$O(^AUPNPREF("AA",BHSPAT,F,E,D)) Q:D'=+D!(D>GMTSDLM) D
...S I=0 F S I=$O(^AUPNPREF("AA",BHSPAT,F,E,D,I)) Q:I'=+I D
....S BHSSX(D,"REF",I)=""
N BHSSD,BHSSI,SNO
S BHSSD=0 F S BHSSD=$O(BHSSX(BHSSD)) Q:BHSSD'=+BHSSD!($D(GMTSQIT)) D
.S BHSSI=0 F S BHSSI=$O(BHSSX(BHSSD,"REF",BHSSI)) Q:BHSSI'=+BHSSI!($D(GMTSQIT)) D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W ?3,$$FMTE^XLFDT(9999999-BHSSD),?17,$$VAL^XBDIQ1(9000022,BHSSI,.04)," (",$$VAL^XBDIQ1(9000022,BHSSI,.01),")",!
..S SNO=$$GET1^DIQ(9000022,BHSSI,1.02)
..S SNO=$P($$DESC^BSTSAPI(SNO_"^^1"),U,2)
..I SNO="" S SNO=$$VAL^XBDIQ1(9000022,BHSSI,.07)
..W ?5,"Refusal Type: ",SNO,!
..;W ?5,"Refusal Type: ",$$VAL^XBDIQ1(9000022,BHSSI,.07),!
.S BHSSI=0 F S BHSSI=$O(BHSSX(BHSSD,"IMM",BHSSI)) Q:BHSSI'=+BHSSI!($D(GMTSQIT)) D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W ?3,$$FMTE^XLFDT(9999999-BHSSD),?17,$$VAL^XBDIQ1(9002084.11,BHSSI,.02),!
..W ?5,"Refusal Type: "_$$VAL^XBDIQ1(9002084.11,BHSSI,.03),!
Q
LER ;Refusal component patch 2
;----------------------------------------------------------
K BHSX
S BHSPAT=DFN
S Y=0 F S Y=$O(^BIPC("AC",BHSPAT,Y)) Q:Y'=+Y D
.S X=0 F S X=$O(^BIPC("AC",BHSPAT,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>GMTSDLM
..S BHSX("REF","IMMUNIZATION",$$VAL^XBDIQ1(9002084.11,X,.02),D)=X_U_$$VAL^XBDIQ1(9002084.11,X,.03)
I '$D(^AUPNPREF("AA",BHSPAT)),'$D(BHSX) Q ;no refusals
D CKP^GMTSUP Q:$D(GMTSQIT)
NEW X,F,I,D,E,SNO
S F=0 F S F=$O(^AUPNPREF("AA",BHSPAT,F)) Q:F'=+F D
.S E=0 F S E=$O(^AUPNPREF("AA",BHSPAT,F,E)) Q:E'=+E D
..S D=0 F S D=$O(^AUPNPREF("AA",BHSPAT,F,E,D)) Q:D'=+D!(D>GMTSDLM) D
...S I=0 F S I=$O(^AUPNPREF("AA",BHSPAT,F,E,D,I)) Q:I'=+I D
....S SNO=$$GET1^DIQ(9000022,I,1.02)
....S SNO=$P($$DESC^BSTSAPI(SNO_"^^1"),U,2)
....I SNO="" S SNO=$$VAL^XBDIQ1(9000022,I,.07)
....S BHSX("REF",$$VAL^XBDIQ1(9000022,I,.05),$$VAL^XBDIQ1(9000022,I,.04),D)=I_U_SNO
....;S BHSX("REF",$$VAL^XBDIQ1(9000022,I,.05),$$VAL^XBDIQ1(9000022,I,.04),D)=I_U_$$VAL^XBDIQ1(9000022,I,.07)
NEW BHSD,BHSI,BHSC,BHSDA,BHSRT
S BHSC="" F S BHSC=$O(BHSX("REF",BHSC)) Q:BHSC=""!($D(GMTSQIT)) D
.S BHSI="" F S BHSI=$O(BHSX("REF",BHSC,BHSI)) Q:BHSI=""!($D(GMTSQIT)) D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..S BHSD=$O(BHSX("REF",BHSC,BHSI,0))
..S BHSDA=$P(BHSX("REF",BHSC,BHSI,BHSD),U)
..S BHSRT=$P(BHSX("REF",BHSC,BHSI,BHSD),U,2)
..W ?3,$E(BHSI,1,30),?38,"(",$E($$UP^XLFSTR(BHSRT),1,25),")",?70,$$FMTE^XLFDT(9999999-BHSD,5),!
Q
BHSHS3 ;IHS/CIA/MGH - Health Summary for other components ;06-Aug-2018 15:44;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**2,8,15**;March 17, 2006;Build 8
+2 ;===================================================================
+3 ;VA health summary components for insurance, elder care, and refusals
+4 ;Patch 8 added SNOMED reasons for refusal
+5 ; IHS/TUCSON/LAB - PART 5 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+6 ;;2.0;IHS RPMS/PCC Health Summary;**5,6,8,11**;JUN 24, 1997
+7 ;Patch 2 for changes in patch 16
+8 ;Patch 15 -changes for insurance
INS ; ******************* INSURANCE * 9000003, 9000004, 9000006 *********
+1 NEW BHSPAT
+2 SET BHSPAT=DFN
+3 IF $ORDER(^AUPNMCD("B",BHSPAT,0))=""
IF '$DATA(^AUPNMCR(BHSPAT))
IF '$DATA(^AUPNPRVT(BHSPAT))
IF '$DATA(^AUPNRRE(BHSPAT))
QUIT
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 WRITE "INSURANCE",?25,"NUMBER",?40,"COV",?48,"EL DATE",?59,"SIG DATE",?70,"END DATE",!
+6 DO MAID^BHSINSUR
DO MCARE^BHSINSUR
DO THIRD^BHSINSUR
DO RR^BHSINSUR
INSX KILL BHSSPDN,BHSSINS,BHSSEDN,BHSSN,BHSSIDN,BHSSDTL,BHSSDTN,BHSSUFF,BHSSCOV,BHSSDTS,BHSSI,BHSSJ,BHSSITB
+1 QUIT
+2 ;
+3 ;
ELDER1 ;******************** ELDER CARE 1 * 9000010.35
+1 ;----------------------------------------------------------------
+2 NEW BHSPAT,BHSSP,BHSSY
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVELD("AA",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 WRITE "ADL",!
+7 FOR BHSSY=.04,.05,.06,.07,.08,.09
IF $DATA(GMTSQIT)
QUIT
SET BHSSP=+$PIECE(BHSSY,".",2)
SET BHSSN=$PIECE(^DD(9000010.35,BHSSY,0),U)
DO VAL(BHSPAT,BHSSY,BHSSP,1)
Begin DoDot:1
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+9 WRITE ?2,BHSSN,?28,$$D($PIECE($GET(BHSSX(1)),U)),?40,$PIECE($GET(BHSSX(1)),U,2),!
+10 QUIT
End DoDot:1
+11 WRITE !,"IADL",!
+12 FOR BHSSY=.11,.12,.13,.14,.15,.16
IF $DATA(GMTSQIT)
QUIT
SET BHSSP=+$PIECE(BHSSY,".",2)
SET BHSSN=$PIECE(^DD(9000010.35,BHSSY,0),U)
DO VAL(BHSPAT,BHSSY,BHSSP,1)
Begin DoDot:1
+13 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+14 WRITE ?2,BHSSN,?28,$$D($PIECE($GET(BHSSX(1)),U)),?40,$PIECE($GET(BHSSX(1)),U,2),!
+15 QUIT
End DoDot:1
+16 SET BHSSN="CHANGE IN FUNCTIONAL STATUS"
SET BHSSP=17
SET BHSSY=.17
DO VAL(BHSPAT,BHSSY,BHSSP,1)
+17 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+18 WRITE !,BHSSN,?28,$$D($PIECE($GET(BHSSX(1)),U)),?40,$PIECE($GET(BHSSX(1)),U,2),!
+19 QUIT
+20 ;
ELDER2 ;*********************elder care last 2 of each * 9000010.35
+1 NEW BHSPAT,BHSSP,BHSSY
+2 SET BHSPAT=DFN
+3 IF '$DATA(^AUPNVELD("AA",BHSPAT))
QUIT
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 WRITE "ADL",!
+6 FOR BHSSY=.04,.05,.06,.07,.08,.09
IF $DATA(GMTSQIT)
QUIT
SET BHSSP=+$PIECE(BHSSY,".",2)
SET BHSSN=$PIECE(^DD(9000010.35,BHSSY,0),U)
DO VAL(BHSPAT,BHSSY,BHSSP,2)
Begin DoDot:1
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 WRITE ?2,BHSSN,?28,$$D($PIECE($GET(BHSSX(1)),U)),?40,$PIECE($GET(BHSSX(1)),U,2),!
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 IF $GET(BHSSX(2))]""
WRITE ?28,$$D($PIECE($GET(BHSSX(2)),U)),?40,$PIECE($GET(BHSSX(2)),U,2),!
+11 QUIT
End DoDot:1
+12 WRITE !,"IADL",!
+13 FOR BHSSY=.11,.12,.13,.14,.15,.16
IF $DATA(GMTSQIT)
QUIT
SET BHSSP=+$PIECE(BHSSY,".",2)
SET BHSSN=$PIECE(^DD(9000010.35,BHSSY,0),U)
DO VAL(BHSPAT,BHSSY,BHSSP,2)
Begin DoDot:1
+14 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+15 WRITE ?2,BHSSN,?28,$$D($PIECE($GET(BHSSX(1)),U)),?40,$PIECE($GET(BHSSX(1)),U,2),!
+16 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+17 IF $GET(BHSSX(2))]""
WRITE ?28,$$D($PIECE($GET(BHSSX(2)),U)),?40,$PIECE($GET(BHSSX(2)),U,2),!
+18 QUIT
End DoDot:1
+19 SET BHSSN="CHANGE IN FUNCTIONAL STATUS"
SET BHSSP=17
SET BHSSY=.17
DO VAL(BHSPAT,BHSSY,BHSSP,2)
+20 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+21 WRITE !,BHSSN,?28,$$D($PIECE($GET(BHSSX(1)),U)),?40,$PIECE($GET(BHSSX(1)),U,2),!
+22 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+23 IF $GET(BHSSX(2))]""
WRITE ?28,$$D($PIECE($GET(BHSSX(2)),U)),?40,$PIECE($GET(BHSSX(2)),U,2),!
+24 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+25 QUIT
+26 ;
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 BHSSX
+2 NEW %
FOR %=1:1:I
SET BHSSX(%)=""
+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 BHSSX(C)=9999999-X_"^"_$$VAL^XBDIQ1(9000010.35,Y,F)
+6 QUIT
+7 ;-------------------------------------------------------------------
REFUSAL ;refusal component
+1 ;--------------------------------------------------------------------
+2 NEW BHSPAT,Y,X,R,D,BHSSX
+3 SET BHSPAT=DFN
+4 ;gather any refuals from Immunization package
+5 KILL BHSSX
+6 SET Y=0
FOR
SET Y=$ORDER(^BIPC("AC",BHSPAT,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^BIPC("AC",BHSPAT,Y,X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET R=$PIECE(^BIPC(X,0),U,3)
+9 IF R=""
QUIT
+10 IF '$DATA(^BICONT(R,0))
QUIT
+11 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+12 SET D=$PIECE(^BIPC(X,0),U,4)
+13 IF D=""
QUIT
+14 SET D=9999999-D
+15 IF D>GMTSDLM
QUIT
+16 SET BHSSX(D,"IMM",X)=""
End DoDot:2
End DoDot:1
+17 ;no refusals
IF '$DATA(^AUPNPREF("AA",BHSPAT))
IF '$DATA(BHSSX)
QUIT
+18 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+19 NEW X,F,I,D,E
+20 SET F=0
FOR
SET F=$ORDER(^AUPNPREF("AA",BHSPAT,F))
IF F'=+F
QUIT
Begin DoDot:1
+21 SET E=0
FOR
SET E=$ORDER(^AUPNPREF("AA",BHSPAT,F,E))
IF E'=+E
QUIT
Begin DoDot:2
+22 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",BHSPAT,F,E,D))
IF D'=+D!(D>GMTSDLM)
QUIT
Begin DoDot:3
+23 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",BHSPAT,F,E,D,I))
IF I'=+I
QUIT
Begin DoDot:4
+24 SET BHSSX(D,"REF",I)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 NEW BHSSD,BHSSI,SNO
+26 SET BHSSD=0
FOR
SET BHSSD=$ORDER(BHSSX(BHSSD))
IF BHSSD'=+BHSSD!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+27 SET BHSSI=0
FOR
SET BHSSI=$ORDER(BHSSX(BHSSD,"REF",BHSSI))
IF BHSSI'=+BHSSI!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+28 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+29 WRITE ?3,$$FMTE^XLFDT(9999999-BHSSD),?17,$$VAL^XBDIQ1(9000022,BHSSI,.04)," (",$$VAL^XBDIQ1(9000022,BHSSI,.01),")",!
+30 SET SNO=$$GET1^DIQ(9000022,BHSSI,1.02)
+31 SET SNO=$PIECE($$DESC^BSTSAPI(SNO_"^^1"),U,2)
+32 IF SNO=""
SET SNO=$$VAL^XBDIQ1(9000022,BHSSI,.07)
+33 WRITE ?5,"Refusal Type: ",SNO,!
+34 ;W ?5,"Refusal Type: ",$$VAL^XBDIQ1(9000022,BHSSI,.07),!
End DoDot:2
+35 SET BHSSI=0
FOR
SET BHSSI=$ORDER(BHSSX(BHSSD,"IMM",BHSSI))
IF BHSSI'=+BHSSI!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+36 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+37 WRITE ?3,$$FMTE^XLFDT(9999999-BHSSD),?17,$$VAL^XBDIQ1(9002084.11,BHSSI,.02),!
+38 WRITE ?5,"Refusal Type: "_$$VAL^XBDIQ1(9002084.11,BHSSI,.03),!
End DoDot:2
End DoDot:1
+39 QUIT
LER ;Refusal component patch 2
+1 ;----------------------------------------------------------
+2 KILL BHSX
+3 SET BHSPAT=DFN
+4 SET Y=0
FOR
SET Y=$ORDER(^BIPC("AC",BHSPAT,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^BIPC("AC",BHSPAT,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>GMTSDLM
QUIT
+14 SET BHSX("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",BHSPAT))
IF '$DATA(BHSX)
QUIT
+16 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+17 NEW X,F,I,D,E,SNO
+18 SET F=0
FOR
SET F=$ORDER(^AUPNPREF("AA",BHSPAT,F))
IF F'=+F
QUIT
Begin DoDot:1
+19 SET E=0
FOR
SET E=$ORDER(^AUPNPREF("AA",BHSPAT,F,E))
IF E'=+E
QUIT
Begin DoDot:2
+20 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",BHSPAT,F,E,D))
IF D'=+D!(D>GMTSDLM)
QUIT
Begin DoDot:3
+21 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",BHSPAT,F,E,D,I))
IF I'=+I
QUIT
Begin DoDot:4
+22 SET SNO=$$GET1^DIQ(9000022,I,1.02)
+23 SET SNO=$PIECE($$DESC^BSTSAPI(SNO_"^^1"),U,2)
+24 IF SNO=""
SET SNO=$$VAL^XBDIQ1(9000022,I,.07)
+25 SET BHSX("REF",$$VAL^XBDIQ1(9000022,I,.05),$$VAL^XBDIQ1(9000022,I,.04),D)=I_U_SNO
+26 ;S BHSX("REF",$$VAL^XBDIQ1(9000022,I,.05),$$VAL^XBDIQ1(9000022,I,.04),D)=I_U_$$VAL^XBDIQ1(9000022,I,.07)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 NEW BHSD,BHSI,BHSC,BHSDA,BHSRT
+28 SET BHSC=""
FOR
SET BHSC=$ORDER(BHSX("REF",BHSC))
IF BHSC=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+29 SET BHSI=""
FOR
SET BHSI=$ORDER(BHSX("REF",BHSC,BHSI))
IF BHSI=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+30 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+31 SET BHSD=$ORDER(BHSX("REF",BHSC,BHSI,0))
+32 SET BHSDA=$PIECE(BHSX("REF",BHSC,BHSI,BHSD),U)
+33 SET BHSRT=$PIECE(BHSX("REF",BHSC,BHSI,BHSD),U,2)
+34 WRITE ?3,$EXTRACT(BHSI,1,30),?38,"(",$EXTRACT($$UP^XLFSTR(BHSRT),1,25),")",?70,$$FMTE^XLFDT(9999999-BHSD,5),!
End DoDot:2
End DoDot:1
+35 QUIT
