BDMEDMU3.m

BDMEDMU3 ; IHS/CMI/LAB - prompt for refusal value ; 27 Jan 2011  2:41 PM

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**7,8,10**;JUN 14, 2007;Build 12

 ;

 ;

HEPB(Y) ;EP

 I $G(Y)="" Q 0

 I '$D(^AUTTIMM(Y,0)) Q 0

 I $P(^AUTTIMM(Y,0),U,3)=8 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=42 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=43 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=44 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=45 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=51 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=102 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=104 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=110 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=132 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=146 Q 1

 I $$VAL^XBDIQ1(9999999.14,+Y,.09)="HEPB" Q 1

 Q 0

FLU(Y) ;EP

 I $G(Y)="" Q 0

 I '$D(^AUTTIMM(Y,0)) Q 0

 I $$VAL^XBDIQ1(9999999.14,+Y,.09)="FLU" Q 1

 I $P(^AUTTIMM(Y,0),U,3)=88 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=16 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=15 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=111 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=135 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=140 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=141 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=144 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=123 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=149 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=150 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=151 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=153 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=155 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=158 Q 1

 I $P(^AUTTIMM(Y,0),U,3)=161 Q 1

 I '$O(^ATXAX("B","BGP FLU IZ CVX CODES",0)) Q 0

 NEW Z

 S Z=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))

 NEW C

 S C=$P(^AUTTIMM(Y,0),U,3)

 I $D(^ATXAX(Z,21,"B",C)) Q 1

 Q 0

PN(Y) ;EP

 I $G(Y)="" Q 0

 I '$D(^AUTTIMM(Y,0)) Q 0

 ;I $$VAL^XBDIQ1(9999999.14,+Y,.09)="PNEUMO" Q 1

 N Z

 S Z=$P(^AUTTIMM(Y,0),U,3)

 I Z=33 Q 1

 I Z=109 Q 1

 I '$O(^ATXAX("B","BGP PNEUMO IZ CVX CODES",0)) Q 0

 NEW Z

 S Z=$O(^ATXAX("B","BGP PNEUMO IZ CVX CODES",0))

 NEW C

 S C=$P(^AUTTIMM(Y,0),U,3)

 I $D(^ATXAX(Z,21,"B",C)) Q 1

 Q 0

TD(Y) ;EP

 I $G(Y)="" Q 0

 I '$D(^AUTTIMM(Y,0)) Q 0

 ;I $P(^AUTTIMM(Y,0),U,7)=1 Q 0

 N Z

 S Z=$P(^AUTTIMM(Y,0),U,3)

 I Z=1 Q 1

 I Z=9 Q 1

 I Z=20 Q 1

 I Z=22 Q 1

 I Z=28 Q 1

 I Z=35 Q 1

 I Z=50 Q 1

 I Z=106 Q 1

 I Z=107 Q 1

 I Z=110 Q 1

 I Z=113 Q 1

 I Z=115 Q 1

 I Z=120 Q 1

 I Z=130 Q 1

 I Z=132 Q 1

 I Z=138 Q 1

 I Z=139 Q 1

 I Z=142 Q 1

 Q 0

REF ;EP

 K BDMEX,BDMETF,BDMETERR,BDMETOLD,BDMETID,BDMETIEN,BDMERDN,BDMETREA

 D ^XBFMK K DIADD,DLAYGO

 S DIR(0)="9000022,.03",DIR("A")="Enter Date of Refusals/Declined Service" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D EOJ Q

 S BDMEDRN=Y

 S DIC="^AUTTREFT(",DIC(0)="AEMQ",DIC("A")="Enter Service Type: " D ^DIC K DIC

 I Y=-1 W !,"exiting......." Q

 S BDMEX=+Y

VALUE ;EP - called from input template

 S BDMETF=$P(^AUTTREFT(BDMEX,0),U,2)

 I 'BDMETF S BDMETERR=1 D EOJ Q

 S DIC("B")=$S($D(BDMETOLD):BDMETOLD,1:""),DIC("A")="Enter the "_$P(^DIC(BDMETF,0),U)_" value: ",DIC=BDMETF,DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 W !!,"Invalid entry.  Try again." G REF

 S BDMETIEN=+Y,BDMETID=$$VAL^XBDIQ1(BDMETF,BDMETIEN,$P(^AUTTREFT(BDMEX,0),U,3))

 S DIR(0)="9000022,.07",DIR("A")="Enter Reason not Done" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) W !,"Reason is Required" G REF

 I Y="" W !,"Reason is Required" G REF

 S BDMETREA=Y

 W !,"creating Refusal entry in PCC..."

 K DIC,DLAYGO,DIADD

 S DIC(0)="L",DIC="^AUPNPREF(",X=BDMEX,DIC("DR")=".02////"_BDMEDMPT_";.03////"_BDMEDRN_";.04////"_BDMETID_";.05////"_BDMETF_";.06////"_BDMETIEN_";.07////"_BDMETREA K DD,D0 D FILE^DICN

 I Y=-1 W !!,"Creating refusal entry failed...." H 2 D ^XBFMK G REF

 D ^XBFMK

 K DIADD,DLAYGO

 W !! S DIR(0)="Y",DIR("A")="Would you like to enter another Service not done",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D EOJ Q

 I 'Y D EOJ Q

 G REF

EOJ ;

 K BDMEX,BDMETF,BDMETERR,BDMETOLD,BDMETID,BDMETIEN

 D ^XBFMK

 K Y

 Q

BTL(A) ;EP - called from screen on BARRIERS TO LEARN

 I '$D(^AUTTHF(A,0)) Q 0

 I $P(^AUTTHF(A,0),U,10)'="F" Q 0

 I $P(^AUTTHF(A,0),U,13) Q 0

 NEW B S B=$O(^AUTTHF("B","BARRIERS TO LEARNING",0)) I 'B Q 0

 I $P(^AUTTHF(A,0),U,3)'=B Q 0

 Q 1

 ;

RTL(A) ;EP - called from dd

 I '$D(^AUTTHF(A,0)) Q 0

 I $P(^AUTTHF(A,0),U,10)'="F" Q 0

 I $P(^AUTTHF(A,0),U,13) Q 0

 NEW B S B=$O(^AUTTHF("B","READINESS TO LEARN",0)) I 'B Q 0

 I $P(^AUTTHF(A,0),U,3)'=B Q 0

 Q 1

 ;

LP(A) ;EP - called from screen on LEARNING PREFERENCE

 I '$D(^AUTTHF(A,0)) Q 0

 I $P(^AUTTHF(A,0),U,10)'="F" Q 0

 I $P(^AUTTHF(A,0),U,13) Q 0

 NEW B S B=$O(^AUTTHF("B","LEARNING PREFERENCE",0)) I 'B Q 0

 I $P(^AUTTHF(A,0),U,3)'=B Q 0

 Q 1

BTLHF ;EP

 K BDMEVSIT

 I $P($G(^BDMEDMUP(BDMEDA,11)),U,8)="" Q

 S BDMEDMDT=$S($P(BDMEREC1,U,17)]"":$P(BDMEREC1,U,17),1:DT)

 S BDMEMTYP=$P(^BDMEDMUP(BDMEDA,11),U,8)

 S BDMEMCAT=$P(^AUTTHF(BDMEMTYP,0),U,3)

 D EVSIT^BDMEDMUP ;get event visit

 I '$G(BDMEVSIT) S T="Could not Create PCC Visit when attempting to update Barriers to Learning health factor." D ERR^BDMEDMUP(T) Q

 S (X,G)=0 F  S X=$O(^AUPNVHF("AD",BDMEVSIT,X)) Q:X'=+X!(G)  I $P(^AUPNVHF(X,0),U)=BDMEMTYP S G=1

 I G S T="Already have a health factor of "_$P(^AUTTHF($P(^BDMEDMUP(BDMEDA,11),U,8),0),U)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(BDMEVSIT,0),U)) D ERR^BDMEDMUP(T) Q

 K APCDALVR

 S APCDALVR("APCDPAT")=BDMEDMPT

 S APCDALVR("APCDVSIT")=BDMEVSIT

 S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"

 S APCDALVR("APCDTHF")="`"_BDMEMTYP

 D ^APCDALVR

 I $D(APCDALVR("APCDAFLG")) S T="Error creating V Health Factor Entry for Barriers to Learning.  PCC not updated." D ERR^BDMEDMUP(T)

 K APCDALVR

 ;update health status

 ;S BDMEHSE="",X=0 F  S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE)  I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X

 ;I BDMEHSE D  Q

 ;.D ^XBFMK K DIADD

 ;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE

 ;.I $D(Y) S T="Error updating Health Status entry for Barriers to Learning." D ERR^BDMEDMUP(T)

 ;.D ^XBFMK

 ;D ^XBFMK

 ;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN

 ;I Y=-1 S T="Error adding health status entry for Barriers to Learning." D ERR^BDMEDMUP(T)

 D ^XBFMK K DIADD,DLAYGO

 Q

RTLHF ;EP

 K BDMEVSIT

 I $P($G(^BDMEDMUP(BDMEDA,11)),U,9)="" Q

 S BDMEDMDT=$S($P(BDMEREC1,U,18)]"":$P(BDMEREC1,U,18),1:DT)

 S BDMEMTYP=$P(^BDMEDMUP(BDMEDA,11),U,9)

 S BDMEMCAT=$P(^AUTTHF(BDMEMTYP,0),U,3)

 D EVSIT^BDMEDMUP ;get event visit

 I '$G(BDMEVSIT) S T="Could not Create PCC Visit when attempting to update READINESS TO LEARN health factor." D ERR^BDMEDMUP(T) Q

 S (X,G)=0 F  S X=$O(^AUPNVHF("AD",BDMEVSIT,X)) Q:X'=+X!(G)  I $P(^AUPNVHF(X,0),U)=BDMEMTYP S G=1

 I G S T="Already have a health factor of "_$P(^AUTTHF($P(^BDMEDMUP(BDMEDA,11),U,9),0),U)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(BDMEVSIT,0),U)) D ERR^BDMEDMUP(T) Q

 K APCDALVR

 S APCDALVR("APCDPAT")=BDMEDMPT

 S APCDALVR("APCDVSIT")=BDMEVSIT

 S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"

 S APCDALVR("APCDTHF")="`"_BDMEMTYP

 D ^APCDALVR

 I $D(APCDALVR("APCDAFLG")) S T="Error creating V Health Factor Entry for READINESS TO LEARN.  PCC not updated." D ERR^BDMEDMUP(T)

 K APCDALVR

 ;S BDMEHSE="",X=0 F  S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE)  I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X

 ;I BDMEHSE D  Q

 ;.D ^XBFMK K DIADD

 ;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE

 ;.I $D(Y) S T="Error updating Health Status entry for READINESS TO LEARN." D ERR^BDMEDMUP(T)

 ;.D ^XBFMK

 ;D ^XBFMK

 ;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN

 ;I Y=-1 S T="Error adding health status entry for READINESS TO LEARN." D ERR^BDMEDMUP(T)

 D ^XBFMK K DIADD,DLAYGO

 Q

 ;

LPHF ;EP

 K BDMEVSIT

 I $P($G(^BDMEDMUP(BDMEDA,11)),U,10)="" Q

 S BDMEDMDT=$S($P(BDMEREC1,U,19)]"":$P(BDMEREC1,U,19),1:DT)

 S BDMEMTYP=$P(^BDMEDMUP(BDMEDA,11),U,10)

 S BDMEMCAT=$P(^AUTTHF(BDMEMTYP,0),U,3)

 D EVSIT^BDMEDMUP ;get event visit

 I '$G(BDMEVSIT) S T="Could not Create PCC Visit when attempting to update LEARNING PREFERENCE health factor." D ERR^BDMEDMUP(T) Q

 S (X,G)=0 F  S X=$O(^AUPNVHF("AD",BDMEVSIT,X)) Q:X'=+X!(G)  I $P(^AUPNVHF(X,0),U)=BDMEMTYP S G=1

 I G S T="Already have a health factor of "_$P(^AUTTHF($P(^BDMEDMUP(BDMEDA,11),U,10),0),U)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(BDMEVSIT,0),U)) D ERR^BDMEDMUP(T) Q

 K APCDALVR

 S APCDALVR("APCDPAT")=BDMEDMPT

 S APCDALVR("APCDVSIT")=BDMEVSIT

 S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"

 S APCDALVR("APCDTHF")="`"_BDMEMTYP

 D ^APCDALVR

 I $D(APCDALVR("APCDAFLG")) S T="Error creating V Health Factor Entry for LEARNING PREFERENCE.  PCC not updated." D ERR^BDMEDMUP(T)

 K APCDALVR

 ;S BDMEHSE="",X=0 F  S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE)  I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X

 ;I BDMEHSE D  Q

 ;.D ^XBFMK K DIADD

 ;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE

 ;.I $D(Y) S T="Error updating Health Status entry for LEARNING PREFERENCE." D ERR^BDMEDMUP(T)

 ;.D ^XBFMK

 ;D ^XBFMK

 ;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN

 ;I Y=-1 S T="Error adding health status entry for LEARNING PREFERENCE." D ERR^BDMEDMUP(T)

 D ^XBFMK K DIADD,DLAYGO

 Q

 ;

BDMEDMU3  ; IHS/CMI/LAB - prompt for refusal value ; 27 Jan 2011  2:41 PM

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**7,8,10**;JUN 14, 2007;Build 12

 +2       ;

 +3       ;

HEPB(Y)   ;EP

 +1        IF $GET(Y)=""

               QUIT 0

 +2        IF '$DATA(^AUTTIMM(Y,0))

               QUIT 0

 +3        IF $PIECE(^AUTTIMM(Y,0),U,3)=8

               QUIT 1

 +4        IF $PIECE(^AUTTIMM(Y,0),U,3)=42

               QUIT 1

 +5        IF $PIECE(^AUTTIMM(Y,0),U,3)=43

               QUIT 1

 +6        IF $PIECE(^AUTTIMM(Y,0),U,3)=44

               QUIT 1

 +7        IF $PIECE(^AUTTIMM(Y,0),U,3)=45

               QUIT 1

 +8        IF $PIECE(^AUTTIMM(Y,0),U,3)=51

               QUIT 1

 +9        IF $PIECE(^AUTTIMM(Y,0),U,3)=102

               QUIT 1

 +10       IF $PIECE(^AUTTIMM(Y,0),U,3)=104

               QUIT 1

 +11       IF $PIECE(^AUTTIMM(Y,0),U,3)=110

               QUIT 1

 +12       IF $PIECE(^AUTTIMM(Y,0),U,3)=132

               QUIT 1

 +13       IF $PIECE(^AUTTIMM(Y,0),U,3)=146

               QUIT 1

 +14       IF $$VAL^XBDIQ1(9999999.14,+Y,.09)="HEPB"

               QUIT 1

 +15       QUIT 0

FLU(Y)    ;EP

 +1        IF $GET(Y)=""

               QUIT 0

 +2        IF '$DATA(^AUTTIMM(Y,0))

               QUIT 0

 +3        IF $$VAL^XBDIQ1(9999999.14,+Y,.09)="FLU"

               QUIT 1

 +4        IF $PIECE(^AUTTIMM(Y,0),U,3)=88

               QUIT 1

 +5        IF $PIECE(^AUTTIMM(Y,0),U,3)=16

               QUIT 1

 +6        IF $PIECE(^AUTTIMM(Y,0),U,3)=15

               QUIT 1

 +7        IF $PIECE(^AUTTIMM(Y,0),U,3)=111

               QUIT 1

 +8        IF $PIECE(^AUTTIMM(Y,0),U,3)=135

               QUIT 1

 +9        IF $PIECE(^AUTTIMM(Y,0),U,3)=140

               QUIT 1

 +10       IF $PIECE(^AUTTIMM(Y,0),U,3)=141

               QUIT 1

 +11       IF $PIECE(^AUTTIMM(Y,0),U,3)=144

               QUIT 1

 +12       IF $PIECE(^AUTTIMM(Y,0),U,3)=123

               QUIT 1

 +13       IF $PIECE(^AUTTIMM(Y,0),U,3)=149

               QUIT 1

 +14       IF $PIECE(^AUTTIMM(Y,0),U,3)=150

               QUIT 1

 +15       IF $PIECE(^AUTTIMM(Y,0),U,3)=151

               QUIT 1

 +16       IF $PIECE(^AUTTIMM(Y,0),U,3)=153

               QUIT 1

 +17       IF $PIECE(^AUTTIMM(Y,0),U,3)=155

               QUIT 1

 +18       IF $PIECE(^AUTTIMM(Y,0),U,3)=158

               QUIT 1

 +19       IF $PIECE(^AUTTIMM(Y,0),U,3)=161

               QUIT 1

 +20       IF '$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))

               QUIT 0

 +21       NEW Z

 +22       SET Z=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))

 +23       NEW C

 +24       SET C=$PIECE(^AUTTIMM(Y,0),U,3)

 +25       IF $DATA(^ATXAX(Z,21,"B",C))

               QUIT 1

 +26       QUIT 0

PN(Y)     ;EP

 +1        IF $GET(Y)=""

               QUIT 0

 +2        IF '$DATA(^AUTTIMM(Y,0))

               QUIT 0

 +3       ;I $$VAL^XBDIQ1(9999999.14,+Y,.09)="PNEUMO" Q 1

 +4        NEW Z

 +5        SET Z=$PIECE(^AUTTIMM(Y,0),U,3)

 +6        IF Z=33

               QUIT 1

 +7        IF Z=109

               QUIT 1

 +8        IF '$ORDER(^ATXAX("B","BGP PNEUMO IZ CVX CODES",0))

               QUIT 0

 +9        NEW Z

 +10       SET Z=$ORDER(^ATXAX("B","BGP PNEUMO IZ CVX CODES",0))

 +11       NEW C

 +12       SET C=$PIECE(^AUTTIMM(Y,0),U,3)

 +13       IF $DATA(^ATXAX(Z,21,"B",C))

               QUIT 1

 +14       QUIT 0

TD(Y)     ;EP

 +1        IF $GET(Y)=""

               QUIT 0

 +2        IF '$DATA(^AUTTIMM(Y,0))

               QUIT 0

 +3       ;I $P(^AUTTIMM(Y,0),U,7)=1 Q 0

 +4        NEW Z

 +5        SET Z=$PIECE(^AUTTIMM(Y,0),U,3)

 +6        IF Z=1

               QUIT 1

 +7        IF Z=9

               QUIT 1

 +8        IF Z=20

               QUIT 1

 +9        IF Z=22

               QUIT 1

 +10       IF Z=28

               QUIT 1

 +11       IF Z=35

               QUIT 1

 +12       IF Z=50

               QUIT 1

 +13       IF Z=106

               QUIT 1

 +14       IF Z=107

               QUIT 1

 +15       IF Z=110

               QUIT 1

 +16       IF Z=113

               QUIT 1

 +17       IF Z=115

               QUIT 1

 +18       IF Z=120

               QUIT 1

 +19       IF Z=130

               QUIT 1

 +20       IF Z=132

               QUIT 1

 +21       IF Z=138

               QUIT 1

 +22       IF Z=139

               QUIT 1

 +23       IF Z=142

               QUIT 1

 +24       QUIT 0

REF       ;EP

 +1        KILL BDMEX,BDMETF,BDMETERR,BDMETOLD,BDMETID,BDMETIEN,BDMERDN,BDMETREA

 +2        DO ^XBFMK

           KILL DIADD,DLAYGO

 +3        SET DIR(0)="9000022,.03"

           SET DIR("A")="Enter Date of Refusals/Declined Service"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               DO EOJ

               QUIT 

 +5        SET BDMEDRN=Y

 +6        SET DIC="^AUTTREFT("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Enter Service Type: "

           DO ^DIC

           KILL DIC

 +7        IF Y=-1

               WRITE !,"exiting......."

               QUIT 

 +8        SET BDMEX=+Y

VALUE     ;EP - called from input template

 +1        SET BDMETF=$PIECE(^AUTTREFT(BDMEX,0),U,2)

 +2        IF 'BDMETF

               SET BDMETERR=1

               DO EOJ

               QUIT 

 +3        SET DIC("B")=$SELECT($DATA(BDMETOLD):BDMETOLD,1:"")

           SET DIC("A")="Enter the "_$PIECE(^DIC(BDMETF,0),U)_" value: "

           SET DIC=BDMETF

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +4        IF Y=-1

               WRITE !!,"Invalid entry.  Try again."

               GOTO REF

 +5        SET BDMETIEN=+Y

           SET BDMETID=$$VAL^XBDIQ1(BDMETF,BDMETIEN,$PIECE(^AUTTREFT(BDMEX,0),U,3))

 +6        SET DIR(0)="9000022,.07"

           SET DIR("A")="Enter Reason not Done"

           KILL DA

           DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               WRITE !,"Reason is Required"

               GOTO REF

 +8        IF Y=""

               WRITE !,"Reason is Required"

               GOTO REF

 +9        SET BDMETREA=Y

 +10       WRITE !,"creating Refusal entry in PCC..."

 +11       KILL DIC,DLAYGO,DIADD

 +12       SET DIC(0)="L"

           SET DIC="^AUPNPREF("

           SET X=BDMEX

           SET DIC("DR")=".02////"_BDMEDMPT_";.03////"_BDMEDRN_";.04////"_BDMETID_";.05////"_BDMETF_";.06////"_BDMETIEN_";.07////"_BDMETREA

           KILL DD,D0

           DO FILE^DICN

 +13       IF Y=-1

               WRITE !!,"Creating refusal entry failed...."

               HANG 2

               DO ^XBFMK

               GOTO REF

 +14       DO ^XBFMK

 +15       KILL DIADD,DLAYGO

 +16       WRITE !!

           SET DIR(0)="Y"

           SET DIR("A")="Would you like to enter another Service not done"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +17       IF $DATA(DIRUT)

               DO EOJ

               QUIT 

 +18       IF 'Y

               DO EOJ

               QUIT 

 +19       GOTO REF

EOJ       ;

 +1        KILL BDMEX,BDMETF,BDMETERR,BDMETOLD,BDMETID,BDMETIEN

 +2        DO ^XBFMK

 +3        KILL Y

 +4        QUIT 

BTL(A)    ;EP - called from screen on BARRIERS TO LEARN

 +1        IF '$DATA(^AUTTHF(A,0))

               QUIT 0

 +2        IF $PIECE(^AUTTHF(A,0),U,10)'="F"

               QUIT 0

 +3        IF $PIECE(^AUTTHF(A,0),U,13)

               QUIT 0

 +4        NEW B

           SET B=$ORDER(^AUTTHF("B","BARRIERS TO LEARNING",0))

           IF 'B

               QUIT 0

 +5        IF $PIECE(^AUTTHF(A,0),U,3)'=B

               QUIT 0

 +6        QUIT 1

 +7       ;

RTL(A)    ;EP - called from dd

 +1        IF '$DATA(^AUTTHF(A,0))

               QUIT 0

 +2        IF $PIECE(^AUTTHF(A,0),U,10)'="F"

               QUIT 0

 +3        IF $PIECE(^AUTTHF(A,0),U,13)

               QUIT 0

 +4        NEW B

           SET B=$ORDER(^AUTTHF("B","READINESS TO LEARN",0))

           IF 'B

               QUIT 0

 +5        IF $PIECE(^AUTTHF(A,0),U,3)'=B

               QUIT 0

 +6        QUIT 1

 +7       ;

LP(A)     ;EP - called from screen on LEARNING PREFERENCE

 +1        IF '$DATA(^AUTTHF(A,0))

               QUIT 0

 +2        IF $PIECE(^AUTTHF(A,0),U,10)'="F"

               QUIT 0

 +3        IF $PIECE(^AUTTHF(A,0),U,13)

               QUIT 0

 +4        NEW B

           SET B=$ORDER(^AUTTHF("B","LEARNING PREFERENCE",0))

           IF 'B

               QUIT 0

 +5        IF $PIECE(^AUTTHF(A,0),U,3)'=B

               QUIT 0

 +6        QUIT 1

BTLHF     ;EP

 +1        KILL BDMEVSIT

 +2        IF $PIECE($GET(^BDMEDMUP(BDMEDA,11)),U,8)=""

               QUIT 

 +3        SET BDMEDMDT=$SELECT($PIECE(BDMEREC1,U,17)]"":$PIECE(BDMEREC1,U,17),1:DT)

 +4        SET BDMEMTYP=$PIECE(^BDMEDMUP(BDMEDA,11),U,8)

 +5        SET BDMEMCAT=$PIECE(^AUTTHF(BDMEMTYP,0),U,3)

 +6       ;get event visit

           DO EVSIT^BDMEDMUP

 +7        IF '$GET(BDMEVSIT)

               SET T="Could not Create PCC Visit when attempting to update Barriers to Learning health factor."

               DO ERR^BDMEDMUP(T)

               QUIT 

 +8        SET (X,G)=0

           FOR 

               SET X=$ORDER(^AUPNVHF("AD",BDMEVSIT,X))

               IF X'=+X!(G)

                   QUIT 

               IF $PIECE(^AUPNVHF(X,0),U)=BDMEMTYP

                   SET G=1

 +9        IF G

               SET T="Already have a health factor of "_$PIECE(^AUTTHF($PIECE(^BDMEDMUP(BDMEDA,11),U,8),0),U)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(BDMEVSIT,0),U))

               DO ERR^BDMEDMUP(T)

               QUIT 

 +10       KILL APCDALVR

 +11       SET APCDALVR("APCDPAT")=BDMEDMPT

 +12       SET APCDALVR("APCDVSIT")=BDMEVSIT

 +13       SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"

 +14       SET APCDALVR("APCDTHF")="`"_BDMEMTYP

 +15       DO ^APCDALVR

 +16       IF $DATA(APCDALVR("APCDAFLG"))

               SET T="Error creating V Health Factor Entry for Barriers to Learning.  PCC not updated."

               DO ERR^BDMEDMUP(T)

 +17       KILL APCDALVR

 +18      ;update health status

 +19      ;S BDMEHSE="",X=0 F  S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE)  I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X

 +20      ;I BDMEHSE D  Q

 +21      ;.D ^XBFMK K DIADD

 +22      ;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE

 +23      ;.I $D(Y) S T="Error updating Health Status entry for Barriers to Learning." D ERR^BDMEDMUP(T)

 +24      ;.D ^XBFMK

 +25      ;D ^XBFMK

 +26      ;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN

 +27      ;I Y=-1 S T="Error adding health status entry for Barriers to Learning." D ERR^BDMEDMUP(T)

 +28       DO ^XBFMK

           KILL DIADD,DLAYGO

 +29       QUIT 

RTLHF     ;EP

 +1        KILL BDMEVSIT

 +2        IF $PIECE($GET(^BDMEDMUP(BDMEDA,11)),U,9)=""

               QUIT 

 +3        SET BDMEDMDT=$SELECT($PIECE(BDMEREC1,U,18)]"":$PIECE(BDMEREC1,U,18),1:DT)

 +4        SET BDMEMTYP=$PIECE(^BDMEDMUP(BDMEDA,11),U,9)

 +5        SET BDMEMCAT=$PIECE(^AUTTHF(BDMEMTYP,0),U,3)

 +6       ;get event visit

           DO EVSIT^BDMEDMUP

 +7        IF '$GET(BDMEVSIT)

               SET T="Could not Create PCC Visit when attempting to update READINESS TO LEARN health factor."

               DO ERR^BDMEDMUP(T)

               QUIT 

 +8        SET (X,G)=0

           FOR 

               SET X=$ORDER(^AUPNVHF("AD",BDMEVSIT,X))

               IF X'=+X!(G)

                   QUIT 

               IF $PIECE(^AUPNVHF(X,0),U)=BDMEMTYP

                   SET G=1

 +9        IF G

               SET T="Already have a health factor of "_$PIECE(^AUTTHF($PIECE(^BDMEDMUP(BDMEDA,11),U,9),0),U)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(BDMEVSIT,0),U))

               DO ERR^BDMEDMUP(T)

               QUIT 

 +10       KILL APCDALVR

 +11       SET APCDALVR("APCDPAT")=BDMEDMPT

 +12       SET APCDALVR("APCDVSIT")=BDMEVSIT

 +13       SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"

 +14       SET APCDALVR("APCDTHF")="`"_BDMEMTYP

 +15       DO ^APCDALVR

 +16       IF $DATA(APCDALVR("APCDAFLG"))

               SET T="Error creating V Health Factor Entry for READINESS TO LEARN.  PCC not updated."

               DO ERR^BDMEDMUP(T)

 +17       KILL APCDALVR

 +18      ;S BDMEHSE="",X=0 F  S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE)  I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X

 +19      ;I BDMEHSE D  Q

 +20      ;.D ^XBFMK K DIADD

 +21      ;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE

 +22      ;.I $D(Y) S T="Error updating Health Status entry for READINESS TO LEARN." D ERR^BDMEDMUP(T)

 +23      ;.D ^XBFMK

 +24      ;D ^XBFMK

 +25      ;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN

 +26      ;I Y=-1 S T="Error adding health status entry for READINESS TO LEARN." D ERR^BDMEDMUP(T)

 +27       DO ^XBFMK

           KILL DIADD,DLAYGO

 +28       QUIT 

 +29      ;

LPHF      ;EP

 +1        KILL BDMEVSIT

 +2        IF $PIECE($GET(^BDMEDMUP(BDMEDA,11)),U,10)=""

               QUIT 

 +3        SET BDMEDMDT=$SELECT($PIECE(BDMEREC1,U,19)]"":$PIECE(BDMEREC1,U,19),1:DT)

 +4        SET BDMEMTYP=$PIECE(^BDMEDMUP(BDMEDA,11),U,10)

 +5        SET BDMEMCAT=$PIECE(^AUTTHF(BDMEMTYP,0),U,3)

 +6       ;get event visit

           DO EVSIT^BDMEDMUP

 +7        IF '$GET(BDMEVSIT)

               SET T="Could not Create PCC Visit when attempting to update LEARNING PREFERENCE health factor."

               DO ERR^BDMEDMUP(T)

               QUIT 

 +8        SET (X,G)=0

           FOR 

               SET X=$ORDER(^AUPNVHF("AD",BDMEVSIT,X))

               IF X'=+X!(G)

                   QUIT 

               IF $PIECE(^AUPNVHF(X,0),U)=BDMEMTYP

                   SET G=1

 +9        IF G

               SET T="Already have a health factor of "_$PIECE(^AUTTHF($PIECE(^BDMEDMUP(BDMEDA,11),U,10),0),U)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(BDMEVSIT,0),U))

               DO ERR^BDMEDMUP(T)

               QUIT 

 +10       KILL APCDALVR

 +11       SET APCDALVR("APCDPAT")=BDMEDMPT

 +12       SET APCDALVR("APCDVSIT")=BDMEVSIT

 +13       SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"

 +14       SET APCDALVR("APCDTHF")="`"_BDMEMTYP

 +15       DO ^APCDALVR

 +16       IF $DATA(APCDALVR("APCDAFLG"))

               SET T="Error creating V Health Factor Entry for LEARNING PREFERENCE.  PCC not updated."

               DO ERR^BDMEDMUP(T)

 +17       KILL APCDALVR

 +18      ;S BDMEHSE="",X=0 F  S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE)  I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X

 +19      ;I BDMEHSE D  Q

 +20      ;.D ^XBFMK K DIADD

 +21      ;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE

 +22      ;.I $D(Y) S T="Error updating Health Status entry for LEARNING PREFERENCE." D ERR^BDMEDMUP(T)

 +23      ;.D ^XBFMK

 +24      ;D ^XBFMK

 +25      ;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN

 +26      ;I Y=-1 S T="Error adding health status entry for LEARNING PREFERENCE." D ERR^BDMEDMUP(T)

 +27       DO ^XBFMK

           KILL DIADD,DLAYGO

 +28       QUIT 

 +29      ;