AMHLCD ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-JAN-1997 ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;; ;
;
EP1(DFN) ;EP - CALLED FROM PROTOCOL
Q:'$G(DFN)
Q:'$D(^DPT(DFN))
Q:$P(^DPT(DFN,0),U,19)
D EN
D FULL^VALM1
K VALMHDR
Q
EP ;EP CALLED FROM DATA ENTRY
Q:'$G(AMHPAT)
S DFN=AMHPAT
S Y=AMHPAT D ^AUPNPAT
D EN
Q
START ;update case data
K AMHCASE,AMHX
W:$D(IOF) @IOF W !!,"*** Update Patient Case Data ***",!!
S DFN="" F D GETPAT Q:DFN="" D EN,FULL^VALM1,EXIT
D EOJ
Q
EN ; -- main entry point for AMH UPDATE PATIENT CASE DATA
D EN^VALM("AMH UPDATE PATIENT CASE DATA")
K AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
Q
;
HDR ; -- header code
S VALMHDR(1)=$TR($J(" ",80)," ","-")
S VALMHDR(2)="Patient Name: "_$E($P(^DPT(DFN,0),U),1,24)_" DOB: "_$$DATE($P(^DPT(DFN,0),U,3))_" Sex: "_$P(^DPT(DFN,0),U,2)_" HRN: "_$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"??????")
S VALMHDR(3)=$TR($J(" ",80)," ","-")
S VALMHDR(4)=""
S VALMHDR(5)="# PROGRAM OPEN ADMIT CLOSED DISPOSITION PROVIDER"
Q
;
GETPAT ;
S DFN=""
W:$D(IOF) @IOF
W !!!!!!!!?20,"TYPE THE PATIENT'S HRN, NAME, SSN OR DOB" S DIC("A")=" Patient: "
S DFN=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
I Y<0 Q
S DFN=+Y
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
Q
INIT ; -- init variables and list array
S VALMSG="?? for more actions + next screen - prev screen"
D GATHER ;gather up all records for display
S VALMCNT=AMHLINE
Q
;
GATHER ;
S AMHRCNT=0,AMHLINE=0
S AMHD=0 F S AMHD=$O(^AMHPCASE("AA",DFN,AMHD)) Q:AMHD'=+AMHD D
.S AMHX=0 F S AMHX=$O(^AMHPCASE("AA",DFN,AMHD,AMHX)) Q:AMHX'=+AMHX D
..Q:'$$ALLOWCD(DUZ,AMHX) ;DON'T ALLOW VIEWING OF CASES NOT BY THIS PROVIDER IS NOT IN SDE
..S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,%=^AMHPCASE(AMHX,0),Y=AMHRCNT
..S $E(Y,5)=$E($$VAL^XBDIQ1(9002011.58,AMHX,.03),1,6),$E(Y,14)=$$FMTE^XLFDT($P(%,U),"2E"),$E(Y,24)=$$FMTE^XLFDT($P(%,U,4),"2E"),$E(Y,34)=$$FMTE^XLFDT($P(%,U,5),"2E")
..S $E(Y,43)=$E($$VAL^XBDIQ1(9002011.58,AMHX,.06),1,20),$E(Y,65)=$E($$VAL^XBDIQ1(9002011.58,AMHX,.08),1,15)
..S AMHCASE(AMHLINE,0)=Y,AMHCASE("IDX",AMHLINE,AMHRCNT)=AMHX
..I $$VAL^XBDIQ1(9002011.58,AMHX,1101)]"" S AMHLINE=AMHLINE+1,AMHCASE(AMHLINE,0)=" COMMENT: "_$E($$VAL^XBDIQ1(9002011.58,AMHX,1101),1,58)_" **",AMHCASE("IDX",AMHLINE,AMHRCNT)=AMHX
..I $P(%,U,9)]""!($P(%,U,12)]"") S AMHLINE=AMHLINE+1 D
...S AMHCASE(AMHLINE,0)=" Primary Problem: "_$S($P(%,U,9)]"":$P(^AMHPROB($P(%,U,9),0),U)_" "_$E($P(^AMHPROB($P(%,U,9),0),U,2),1,200),1:"")
...S AMHCASE("IDX",AMHLINE,AMHRCNT)=""
...S AMHLINE=AMHLINE+1
...S AMHCASE(AMHLINE,0)=" Next Review: "_$$FMTE^XLFDT($P(%,U,12),"2E"),AMHCASE("IDX",AMHLINE,AMHRCNT)=""
Q
ALLOWCD(S,R) ;EP - CAN THIS USER SEE THIS CASE FORM?
;S is duz, R is CASE ien
I '$G(S) Q 0
I '$G(R) Q 0
I '$D(^AMHPCASE(R,0)) Q 0
NEW P
S P=$P($G(^AMHPCASE(R,0)),U,8)
;I 'P Q 0
I $G(P)="" Q 1
I $D(^AMHSITE(DUZ(2),16,S)) Q 1 ;$$ALLOWP^AMHUTIL(S,P) ;allow all with access
I $P(^AMHPCASE(R,0),U,8)=S Q 1 ;$$ALLOWP^AMHUTIL(S,P) ;allow your own
Q 0
;I $D(^AMHSITE(DUZ(2),16,DUZ)) Q 1 ;allow all with access
;I $P(^AMHPCASE(R,0),U,8)=DUZ Q 1
;Q 0
GETDATE ;
W !!
S AMHCDATE="",DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter CASE OPEN DATE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
S AMHCDATE=Y
Q
OPEN ;EP called from protocol to open a new case
D FULL^VALM1
W:$D(IOF) @IOF
W !!!!,"Opening a Case for ",$P(^DPT(DFN,0),U),!!
D GETDATE
Q:AMHCDATE=""
W !,"Creating new case..." K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHPCASE(",DLAYGO=9002011.58,DIADD=1,X=AMHCDATE,DIC("DR")=".02////"_DFN_";.11///^S X=DT"
D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Behavioral Health Case Record failed !! Deleting Record.",! D PAUSE^AMHLEA Q
S AMHPC=+Y
S DA=AMHPC,DDSFILE=9002011.58,DR="[AMH UPDATE CASE]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
;CHECK RECORD
D DP
D EXIT
Q
EDIT ;
S AMHPC=0
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(AMHCASE("IDX",X)) Q:X'=+X!(AMHPC) I $O(AMHCASE("IDX",X,0))=AMHR1 S Y=$O(AMHCASE("IDX",X,0)),AMHPC=AMHCASE("IDX",X,Y)
I '$D(^AMHPCASE(AMHPC,0)) W !,"Not a valid BH CASE RECORD." K AMHR D PAUSE^AMHLEA D EXIT Q
D FULL^VALM1
S DA=AMHPC,DDSFILE=9002011.58,DR="[AMH UPDATE CASE]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
;CHECK RECORD
I '$D(^AMHPCASE(AMHPC,0)) D EXIT Q
D DP
D EXIT
Q
DP ;
;if provider on the case data or DUZ matches any designated
;provider, then delete that designated provider when case
;is closed
Q:'$G(DA)
Q:'$D(^AMHPCASE(DA,0))
Q:$P(^AMHPCASE(DA,0),U,5)="" ;case not closed
Q:'$D(^AMHPATR(DFN,0)) ;not patient data (designated provs)
NEW AMHA,AMHB
S AMHA=$P(^AMHPCASE(DA,0),U,8)
K DIE,DA,DR
I $P(^AMHPATR(DFN,0),U,2)=DUZ S DA=DFN,DR=".02///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
I $P(^AMHPATR(DFN,0),U,2)=AMHA S DA=DFN,DR=".02///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
I $P(^AMHPATR(DFN,0),U,3)=DUZ S DA=DFN,DR=".03///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
I $P(^AMHPATR(DFN,0),U,3)=AMHA S DA=DFN,DR=".03///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
I $P(^AMHPATR(DFN,0),U,4)=DUZ S DA=DFN,DR=".04///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
I $P(^AMHPATR(DFN,0),U,4)=AMHA S DA=DFN,DR=".04///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
I $P(^AMHPATR(DFN,0),U,12)=AMHA S DA=DFN,DR=".12///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
I $P(^AMHPATR(DFN,0),U,12)=DUZ S DA=DFN,DR=".12///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
;I $P(^AMHPATR(DFN,0),U,13)=AMHA S DA=DFN,DR=".13///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
;I $P(^AMHPATR(DFN,0),U,13)=DUZ S DA=DFN,DR=".13///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K AMHX,AMHCASE,AMHPC,AMHR1
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=AMHLINE
D HDR
K X,Y,Z,I
Q
EOJ ;
K DDSFILE,DIPGM,Y
K X,Y,%,DR,DDS,DA,DIC
K AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
D:$D(VALMWD) CLEAR^VALM1
K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
D KILL^AUPNPAT
Q
DATE(D) ;
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_($E(D,1,3)+1700)
;
EXPND ; -- expand code
Q
;
DEL ;EP - called from protocol entry
D FULL^VALM1
I '$D(^XUSEC("AMHZ DELETE RECORD",DUZ)) W !!,"You do not have the security access to delete a Case.",!,"Please see your supervisor or program manager.",! D PAUSE^AMHLEA,EXIT Q
S AMHPC=0
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(AMHCASE("IDX",X)) Q:X'=+X!(AMHPC) I $O(AMHCASE("IDX",X,0))=AMHR1 S Y=$O(AMHCASE("IDX",X,0)),AMHPC=AMHCASE("IDX",X,Y)
I '$D(^AMHPCASE(AMHPC,0)) W !,"Not a valid BH CASE RECORD." K AMHR D PAUSE^AMHLEA D EXIT Q
D FULL^VALM1
;are you sure??
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this CASE",DIR("B")="N" KILL DA D ^DIR KILL DIR
I 'Y W !!,"Case not deleted." D PAUSE^AMHLEA,EXIT Q
S DA=AMHPC,DIK="^AMHPCASE(" D ^DIK
K DA,DIK
;
D EXIT
Q
AMHLCD ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-JAN-1997 ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;; ;
+3 ;
EP1(DFN) ;EP - CALLED FROM PROTOCOL
+1 IF '$GET(DFN)
QUIT
+2 IF '$DATA(^DPT(DFN))
QUIT
+3 IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+4 DO EN
+5 DO FULL^VALM1
+6 KILL VALMHDR
+7 QUIT
EP ;EP CALLED FROM DATA ENTRY
+1 IF '$GET(AMHPAT)
QUIT
+2 SET DFN=AMHPAT
+3 SET Y=AMHPAT
DO ^AUPNPAT
+4 DO EN
+5 QUIT
START ;update case data
+1 KILL AMHCASE,AMHX
+2 IF $DATA(IOF)
WRITE @IOF
WRITE !!,"*** Update Patient Case Data ***",!!
+3 SET DFN=""
FOR
DO GETPAT
IF DFN=""
QUIT
DO EN
DO FULL^VALM1
DO EXIT
+4 DO EOJ
+5 QUIT
EN ; -- main entry point for AMH UPDATE PATIENT CASE DATA
+1 DO EN^VALM("AMH UPDATE PATIENT CASE DATA")
+2 KILL AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
+3 QUIT
+4 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+2 SET VALMHDR(2)="Patient Name: "_$EXTRACT($PIECE(^DPT(DFN,0),U),1,24)_" DOB: "_$$DATE($PIECE(^DPT(DFN,0),U,3))_" Sex: "_$PIECE(^DPT(DFN,0),U,2)_" HRN: "_$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"????
??")
+3 SET VALMHDR(3)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+4 SET VALMHDR(4)=""
+5 SET VALMHDR(5)="# PROGRAM OPEN ADMIT CLOSED DISPOSITION PROVIDER"
+6 QUIT
+7 ;
GETPAT ;
+1 SET DFN=""
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!!!!!!!?20,"TYPE THE PATIENT'S HRN, NAME, SSN OR DOB"
SET DIC("A")=" Patient: "
+4 SET DFN=""
+5 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+6 IF Y<0
QUIT
+7 SET DFN=+Y
+8 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!!
HANG 2
+9 QUIT
INIT ; -- init variables and list array
+1 SET VALMSG="?? for more actions + next screen - prev screen"
+2 ;gather up all records for display
DO GATHER
+3 SET VALMCNT=AMHLINE
+4 QUIT
+5 ;
GATHER ;
+1 SET AMHRCNT=0
SET AMHLINE=0
+2 SET AMHD=0
FOR
SET AMHD=$ORDER(^AMHPCASE("AA",DFN,AMHD))
IF AMHD'=+AMHD
QUIT
Begin DoDot:1
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPCASE("AA",DFN,AMHD,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+4 ;DON'T ALLOW VIEWING OF CASES NOT BY THIS PROVIDER IS NOT IN SDE
IF '$$ALLOWCD(DUZ,AMHX)
QUIT
+5 SET AMHRCNT=AMHRCNT+1
SET AMHLINE=AMHLINE+1
SET %=^AMHPCASE(AMHX,0)
SET Y=AMHRCNT
+6 SET $EXTRACT(Y,5)=$EXTRACT($$VAL^XBDIQ1(9002011.58,AMHX,.03),1,6)
SET $EXTRACT(Y,14)=$$FMTE^XLFDT($PIECE(%,U),"2E")
SET $EXTRACT(Y,24)=$$FMTE^XLFDT($PIECE(%,U,4),"2E")
SET $EXTRACT(Y,34)=$$FMTE^XLFDT($PIECE(%,U,5),"2E")
+7 SET $EXTRACT(Y,43)=$EXTRACT($$VAL^XBDIQ1(9002011.58,AMHX,.06),1,20)
SET $EXTRACT(Y,65)=$EXTRACT($$VAL^XBDIQ1(9002011.58,AMHX,.08),1,15)
+8 SET AMHCASE(AMHLINE,0)=Y
SET AMHCASE("IDX",AMHLINE,AMHRCNT)=AMHX
+9 IF $$VAL^XBDIQ1(9002011.58,AMHX,1101)]""
SET AMHLINE=AMHLINE+1
SET AMHCASE(AMHLINE,0)=" COMMENT: "_$EXTRACT($$VAL^XBDIQ1(9002011.58,AMHX,1101),1,58)_" **"
SET AMHCASE("IDX",AMHLINE,AMHRCNT)=AMHX
+10 IF $PIECE(%,U,9)]""!($PIECE(%,U,12)]"")
SET AMHLINE=AMHLINE+1
Begin DoDot:3
+11 SET AMHCASE(AMHLINE,0)=" Primary Problem: "_$SELECT($PIECE(%,U,9)]"":$PIECE(^AMHPROB($PIECE(%,U,9),0),U)_" "_$EXTRACT($PIECE(^AMHPROB($PIECE(%,U,9),0),U,2),1,200),1:"")
+12 SET AMHCASE("IDX",AMHLINE,AMHRCNT)=""
+13 SET AMHLINE=AMHLINE+1
+14 SET AMHCASE(AMHLINE,0)=" Next Review: "_$$FMTE^XLFDT($PIECE(%,U,12),"2E")
SET AMHCASE("IDX",AMHLINE,AMHRCNT)=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
ALLOWCD(S,R) ;EP - CAN THIS USER SEE THIS CASE FORM?
+1 ;S is duz, R is CASE ien
+2 IF '$GET(S)
QUIT 0
+3 IF '$GET(R)
QUIT 0
+4 IF '$DATA(^AMHPCASE(R,0))
QUIT 0
+5 NEW P
+6 SET P=$PIECE($GET(^AMHPCASE(R,0)),U,8)
+7 ;I 'P Q 0
+8 IF $GET(P)=""
QUIT 1
+9 ;$$ALLOWP^AMHUTIL(S,P) ;allow all with access
IF $DATA(^AMHSITE(DUZ(2),16,S))
QUIT 1
+10 ;$$ALLOWP^AMHUTIL(S,P) ;allow your own
IF $PIECE(^AMHPCASE(R,0),U,8)=S
QUIT 1
+11 QUIT 0
+12 ;I $D(^AMHSITE(DUZ(2),16,DUZ)) Q 1 ;allow all with access
+13 ;I $P(^AMHPCASE(R,0),U,8)=DUZ Q 1
+14 ;Q 0
GETDATE ;
+1 WRITE !!
+2 SET AMHCDATE=""
SET DIR(0)="DO^:"_DT_":EPTX"
SET DIR("A")="Enter CASE OPEN DATE"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 SET AMHCDATE=Y
+5 QUIT
OPEN ;EP called from protocol to open a new case
+1 DO FULL^VALM1
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!!!,"Opening a Case for ",$PIECE(^DPT(DFN,0),U),!!
+4 DO GETDATE
+5 IF AMHCDATE=""
QUIT
+6 WRITE !,"Creating new case..."
KILL DD,D0,DO,DINUM,DIC,DA,DR
SET DIC(0)="EL"
SET DIC="^AMHPCASE("
SET DLAYGO=9002011.58
SET DIADD=1
SET X=AMHCDATE
SET DIC("DR")=".02////"_DFN_";.11///^S X=DT"
+7 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+8 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health Case Record failed !! Deleting Record.",!
DO PAUSE^AMHLEA
QUIT
+9 SET AMHPC=+Y
+10 SET DA=AMHPC
SET DDSFILE=9002011.58
SET DR="[AMH UPDATE CASE]"
DO ^DDS
+11 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+12 ;CHECK RECORD
+13 DO DP
+14 DO EXIT
+15 QUIT
EDIT ;
+1 SET AMHPC=0
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+4 SET AMHR1=$ORDER(VALMY(0))
IF 'AMHR1
KILL AMHR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+5 SET (X,Y)=0
FOR
SET X=$ORDER(AMHCASE("IDX",X))
IF X'=+X!(AMHPC)
QUIT
IF $ORDER(AMHCASE("IDX",X,0))=AMHR1
SET Y=$ORDER(AMHCASE("IDX",X,0))
SET AMHPC=AMHCASE("IDX",X,Y)
+6 IF '$DATA(^AMHPCASE(AMHPC,0))
WRITE !,"Not a valid BH CASE RECORD."
KILL AMHR
DO PAUSE^AMHLEA
DO EXIT
QUIT
+7 DO FULL^VALM1
+8 SET DA=AMHPC
SET DDSFILE=9002011.58
SET DR="[AMH UPDATE CASE]"
DO ^DDS
+9 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+10 ;CHECK RECORD
+11 IF '$DATA(^AMHPCASE(AMHPC,0))
DO EXIT
QUIT
+12 DO DP
+13 DO EXIT
+14 QUIT
DP ;
+1 ;if provider on the case data or DUZ matches any designated
+2 ;provider, then delete that designated provider when case
+3 ;is closed
+4 IF '$GET(DA)
QUIT
+5 IF '$DATA(^AMHPCASE(DA,0))
QUIT
+6 ;case not closed
IF $PIECE(^AMHPCASE(DA,0),U,5)=""
QUIT
+7 ;not patient data (designated provs)
IF '$DATA(^AMHPATR(DFN,0))
QUIT
+8 NEW AMHA,AMHB
+9 SET AMHA=$PIECE(^AMHPCASE(DA,0),U,8)
+10 KILL DIE,DA,DR
+11 IF $PIECE(^AMHPATR(DFN,0),U,2)=DUZ
SET DA=DFN
SET DR=".02///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+12 IF $PIECE(^AMHPATR(DFN,0),U,2)=AMHA
SET DA=DFN
SET DR=".02///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+13 IF $PIECE(^AMHPATR(DFN,0),U,3)=DUZ
SET DA=DFN
SET DR=".03///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+14 IF $PIECE(^AMHPATR(DFN,0),U,3)=AMHA
SET DA=DFN
SET DR=".03///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+15 IF $PIECE(^AMHPATR(DFN,0),U,4)=DUZ
SET DA=DFN
SET DR=".04///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+16 IF $PIECE(^AMHPATR(DFN,0),U,4)=AMHA
SET DA=DFN
SET DR=".04///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+17 IF $PIECE(^AMHPATR(DFN,0),U,12)=AMHA
SET DA=DFN
SET DR=".12///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+18 IF $PIECE(^AMHPATR(DFN,0),U,12)=DUZ
SET DA=DFN
SET DR=".12///@"
SET DIE="^AMHPATR("
DO ^DIE
KILL DA,DIE,DR
+19 ;I $P(^AMHPATR(DFN,0),U,13)=AMHA S DA=DFN,DR=".13///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
+20 ;I $P(^AMHPATR(DFN,0),U,13)=DUZ S DA=DFN,DR=".13///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
+21 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL AMHX,AMHCASE,AMHPC,AMHR1
+2 DO TERM^VALM0
+3 SET VALMBCK="R"
+4 DO GATHER
+5 SET VALMCNT=AMHLINE
+6 DO HDR
+7 KILL X,Y,Z,I
+8 QUIT
EOJ ;
+1 KILL DDSFILE,DIPGM,Y
+2 KILL X,Y,%,DR,DDS,DA,DIC
+3 KILL AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
+4 IF $DATA(VALMWD)
DO CLEAR^VALM1
+5 KILL VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
+6 DO KILL^AUPNPAT
+7 QUIT
DATE(D) ;
+1 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_($EXTRACT(D,1,3)+1700)
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
DEL ;EP - called from protocol entry
+1 DO FULL^VALM1
+2 IF '$DATA(^XUSEC("AMHZ DELETE RECORD",DUZ))
WRITE !!,"You do not have the security access to delete a Case.",!,"Please see your supervisor or program manager.",!
DO PAUSE^AMHLEA
DO EXIT
QUIT
+3 SET AMHPC=0
+4 DO EN^VALM2(XQORNOD(0),"OS")
+5 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+6 SET AMHR1=$ORDER(VALMY(0))
IF 'AMHR1
KILL AMHR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+7 SET (X,Y)=0
FOR
SET X=$ORDER(AMHCASE("IDX",X))
IF X'=+X!(AMHPC)
QUIT
IF $ORDER(AMHCASE("IDX",X,0))=AMHR1
SET Y=$ORDER(AMHCASE("IDX",X,0))
SET AMHPC=AMHCASE("IDX",X,Y)
+8 IF '$DATA(^AMHPCASE(AMHPC,0))
WRITE !,"Not a valid BH CASE RECORD."
KILL AMHR
DO PAUSE^AMHLEA
DO EXIT
QUIT
+9 DO FULL^VALM1
+10 ;are you sure??
+11 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this CASE"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+12 IF 'Y
WRITE !!,"Case not deleted."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+13 SET DA=AMHPC
SET DIK="^AMHPCASE("
DO ^DIK
+14 KILL DA,DIK
+15 ;
+16 DO EXIT
+17 QUIT
