AMHLESF ; IHS/CMI/LAB - SUICIDE FORM UPDATE ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,2,6**;JUN 02, 2010;Build 10
;
;
START ;
D EN^XBVK("AMH")
W:$D(IOF) @IOF
W $$CTR("Update Suicide Forms",80)
GETPAT ;
S (AMHPAT,DFN)=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 D EOJ Q
I '$$ALLOWP^AMHUTIL(DUZ,DFN) D NALLOWP^AMHUTIL S DFN="" G GETPAT
S (DFN,AMHPAT)=+Y
I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
W !?25,"Ok" S %=1 D YN^DICN I %'=1 S (DFN,AMHPAT)="" D EOJ Q
D EN
END ;
D EOJ
K AMHP,AMHQUIT,AMHW
Q
;
EN ;EP -- main entry point
NEW AMHLEAP
D EN^VALM("AMH VIEW/UPDATE SUICIDE FORM")
K AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE,AMHF,AMHLESF,AMHDP,AMHIISFE,AMHRCNT,AMHSF
Q
;
HDR ; -- header code
S VALMHDR(1)="Suicide Forms on File for: "_IORVON_$P(^DPT(DFN,0),U)_IOINORM
S VALMHDR(2)="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))_" "_$$VAL^XBDIQ1(2,DFN,.02)_" DOB: "_$$DOB^AUPNPAT(DFN,"E")
S VALMHDR(3)="Tribe: "_$E($$TRIBE^AUPNPAT(DFN,"E"),1,25)_" Community: "_$$COMMRES^AUPNPAT(DFN,"E")
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
INIT ;
S VALMSG="?? for more actions + next screen - prev screen"
D GATHER
S VALMCNT=AMHLINE
Q
;
GATHER ;
K AMHLESF
S AMHRCNT=0,AMHLINE=0
I '$D(^AMHPSUIC("AC",DFN)) S AMHLESF(1,0)="No Suicide Forms currently on file for "_$P(^DPT(DFN,0),U),AMHLESF("IDX",1,1)="" S AMHRCNT=1 Q
S AMHSD=0 F S AMHSD=$O(^AMHPSUIC("AA",DFN,AMHSD)) Q:AMHSD'=+AMHSD S AMHSF=0 F S AMHSF=$O(^AMHPSUIC("AA",DFN,AMHSD,AMHSF)) Q:AMHSF'=+AMHSF D
.S AMHRCNT=AMHRCNT+1
.S X=AMHRCNT_") Local Case #: "_$P(^AMHPSUIC(AMHSF,0),U,2),$E(X,35)="Computer Case #: "_$P(^AMHPSUIC(AMHSF,0),U)
.S AMHLINE=AMHLINE+1,AMHLESF(AMHLINE,0)=X,AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
.S X=" Date of Act: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.06),$E(X,35)="Provider: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.03)
.S AMHLINE=AMHLINE+1,AMHLESF(AMHLINE,0)=X,AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
.S X=" Suicidal Behavior: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.131),AMHLINE=AMHLINE+1,AMHLESF(AMHLINE,0)=X,AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
.S Y="",Z=0 F S Z=$O(^AMHPSUIC(AMHSF,11,Z)) Q:Z'=+Z S Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$P(^AMHPSUIC(AMHSF,11,Z,0),U))_" "
.S X=" Method: "_Y,AMHLINE=AMHLINE+1,AMHLESF(AMHLINE,0)=X,AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
.I $$INCOMPSF(AMHSF) S X=" "_IORVON_"[Incomplete Form]"_IOINORM,AMHLINE=AMHLINE+1,AMHLESF(AMHLINE,0)=X,AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
Q
EDIT ;EP
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." G EXIT
S AMHSF=0,(X,Y)=0 F S X=$O(AMHLESF("IDX",X)) Q:X'=+X!(AMHSF) I $O(AMHLESF("IDX",X,0))=R S Y=$O(AMHLESF("IDX",X,0)),AMHSF=AMHLESF("IDX",X,Y)
I '$D(^AMHPSUIC(AMHSF,0)) W !,"Not a valid SUICIDE RECORD." K AMHRDEL,R,AMHSF,R1 D PAUSE D EXIT Q
D FULL^VALM1
S DA=AMHSF,DIE="^AMHPSUIC(",DR=".21////"_DT_";.22////"_DUZ_";.27////"_$$NOW^XLFDT D ^DIE
D ADDDS
D EXIT
Q
DISP ;EP
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." G EXIT
S AMHSF=0,(X,Y)=0 F S X=$O(AMHLESF("IDX",X)) Q:X'=+X!(AMHSF) I $O(AMHLESF("IDX",X,0))=R S Y=$O(AMHLESF("IDX",X,0)),AMHSF=AMHLESF("IDX",X,Y)
I '$D(^AMHPSUIC(AMHSF,0)) W !,"Not a valid SUICIDE RECORD." K AMHRDEL,R,AMHSF,R1 D PAUSE D EXIT Q
D FULL^VALM1
D EP^AMHLESF1(AMHSF)
D EXIT
Q
DEL ;EP - called from protocol
I '$D(^XUSEC("AMHZ DELETE RECORD",DUZ)) W !!,"You do not have the security access to delete a Suicide Form.",!,"Please see your supervisor or program manager.",! D PAUSE,EXIT Q
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." G EXIT
S AMHSF=0,(X,Y)=0 F S X=$O(AMHLESF("IDX",X)) Q:X'=+X!(AMHSF) I $O(AMHLESF("IDX",X,0))=R S Y=$O(AMHLESF("IDX",X,0)),AMHSF=AMHLESF("IDX",X,Y)
I '$D(^AMHPSUIC(AMHSF,0)) W !,"Not a valid SUICIDE RECORD." K AMHRDEL,R,AMHSF,R1 D PAUSE D EXIT Q
D FULL^VALM1
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this suicide form",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
I 'Y D EXIT Q
S DA=AMHSF,DIK="^AMHPSUIC(" D ^DIK
D EXIT
Q
BV ;
NEW AMHPAT
D EP^AMHVD(DFN)
D EXIT
Q
HS ;EP
D FULL^VALM1
S Y=DFN D ^AUPNPAT
D GETTYPE
I '$G(APCHSTYP) D EN^XBVK("APCH") Q
S APCHSPAT=DFN
S %="PCC Health Summary for "_$P(^DPT(APCHSPAT,0),U)
NEW DFN,AMHPAT D VIEWR^XBLM("EN^APCHS",%)
D EN^XBVK("APCH") K AMCHDAYS,AMCHDOB,%
D EXIT
Q
GETTYPE ;
I $G(^AMHSITE(DUZ(2),0))="" D DEFAULT Q
S APCHSTYP=$P(^AMHSITE(DUZ(2),0),U,4) I APCHSTYP="" D DEFAULT Q
I '$D(^APCHSCTL(APCHSTYP)) W !,"Error in Site Parameter File!",$C(7),$C(7) S APCHSTYP="" Q
Q
DEFAULT ;
S APCHSTYP=""
S X="BEHAVIORAL HEALTH",DIC(0)="",DIC="^APCHSCTL(" D ^DIC K DIC,DA
I Y=-1 W !!,"PCC MENTAL HEALTH HEALTH SUMMARY TYPE IS MISSING!! NOTIFY YOUR SUPERVISOR OR SITE MANAGER.",!! Q
S APCHSTYP=+Y
Q
ADDSF(AMHPAT) ;EP
D FULL^VALM1
W:$D(IOF) @IOF
PROV ;
D ^XBFMK
S AMHDP=""
W !! S DIC("A")="Provider Completing the Form: ",DIC="^VA(200,",DIC(0)="AEMQ",DIC("B")=$P(^VA(200,DUZ,0),U) D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Provider Selected." D EXIT Q
S AMHPROV=+Y
GETDATE ;EP
W !!
S AMHDATE="",DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter the DATE of the SUICIDE ACT" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) D EXIT G PROV
S AMHDATE=Y
S X=0,G=0,Y=0,Q=0 F S X=$O(^AMHPSUIC("AC",DFN,X)) Q:X'=+X!(G) I $P(^AMHPSUIC(X,0),U,6)=AMHDATE D
.S Y=1 W !!,"This patient already has a suicide form on file for this Date of Act."
.W !,"The form was filled out by: ",$$VAL^XBDIQ1(9002011.65,X,.03),!
.S DIR(0)="S^A:Continue to ADD a new form;Q:Quit - do not add a new form",DIR("A")="Do you wish to",DIR("B")="Q" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S Y="Q" Q
.I Y="Q" Q
.S G=1
I Y="Q" D PAUSE,EXIT Q
K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHPSUIC(",DLAYGO=9002011.65,DIADD=1,X=$$UPI(AMHPAT,AMHDATE)
S DIC("DR")=".06////"_AMHDATE_";.04////"_AMHPAT_";.03////"_AMHPROV_";.18////"_DT_";.19////"_DUZ_";.21////"_DT_";.22////"_DUZ_";.27////"_$$NOW^XLFDT
S DIC("DR")=DIC("DR")_";9901///1"
D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Error creating Suicide form!! Deleting form.",! D PAUSE,EXIT Q
S AMHSF=+Y
D ADDDS
D EXIT
Q
ADDDS ;
S AMHIISFE=1
S DA=AMHSF,DDSFILE=9002011.65,DR="[AMH SUICIDE FORM UPDATE]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG D PAUSE,EXIT Q
D CHECK
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
CHECK ; check record for completeness
S AMHC=0
F AMHF=.03:.01:.08 I $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)="" W !,$P(^DD(9002011.65,AMHF,0),U)," is a required data element." S AMHC=1
F AMHF=.11,.13:.01:.15,.25 I $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)="" W !,$P(^DD(9002011.65,AMHF,0),U)," is a required data element." S AMHC=1
I $$VAL^XBDIQ1(9002011.65,AMHSF,.25)="OTHER",$$VAL^XBDIQ1(9002011.65,AMHSF,1402)="" S AMHC=1 W !,"Location of Act is OTHER, OTHER description is required."
I $$VAL^XBDIQ1(9002011.65,AMHSF,.25)'="OTHER",$$VAL^XBDIQ1(9002011.65,AMHSF,1402)]"" S DA=AMHSF,DIE="^AMHPSUIC(",DR="1402///@" D ^DIE K DA,DIE,DR
S (Z,X,G)=0 F S X=$O(^AMHPSUIC(AMHSF,11,X)) Q:X'=+X D
.I $P($G(^AMHPSUIC(AMHSF,11,X,0)),U)]"" S G=1
.I $P($G(^AMHPSUIC(AMHSF,11,X,0)),U)=8,$P(^AMHPSUIC(AMHSF,11,X,0),U,2)="" W !,"One of the Methods is OTHER. OTHER description is Required." S AMHC=1
.I $P(^AMHPSUIC(AMHSF,11,X,0),U,1)'=7 K ^AMHPSUIC(AMHSF,11,X,11)
.I $P(^AMHPSUIC(AMHSF,11,X,0),U,1)=7 D
..S Y=0 F S Y=$O(^AMHPSUIC(AMHSF,11,X,11,Y)) Q:Y'=+Y D
...S D=$P(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,1)
...I $P(^AMHTSDRG(D,0),U,2),$P(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,2)="" S AMHC=1 W !,"Method is Overdose, Drug type is Other, Other description is required."
.Q
I 'G W !!,"You must enter a METHOD." S AMHC=1
S G=$P(^AMHPSUIC(AMHSF,0),U,26)
I G="" W !!,"You must enter a value for SUBSTANCE Use. None or Unknown are valid values." S AMHC=1
I G=2 D
.S X=0 F S X=$O(^AMHPSUIC(AMHSF,15,X)) Q:X'=+X D
..S D=$P(^AMHPSUIC(AMHSF,15,X,0),U,1)
..I $P(^AMHTSSU(D,0),U,2),$P(^AMHPSUIC(AMHSF,15,X,0),U,2)="" S AMHC=1 W !,"Substance Involved is Alcohol/Drugs, Drug is Other, Other Description is Required."
S (Z,G,X)=0 F S X=$O(^AMHPSUIC(AMHSF,13,X)) Q:X'=+X D
.I $P($G(^AMHPSUIC(AMHSF,13,X,0)),U)]"" S G=1
.S D=$P(^AMHPSUIC(AMHSF,13,X,0),U,1)
.I $P(^AMHTSCF(D,0),U,1)="OTHER",$P(^AMHPSUIC(AMHSF,13,X,0),U,2)="" S AMHC=1 W !,"Contributing Factor is OTHER, OTHER description is required."
.Q
;NOW CHECK FOR OTHER
I 'G W !!,"You must enter a CONTRIBUTING FACTOR. Unknown is a valid value." S AMHC=1
I $P(^AMHPSUIC(AMHSF,0),U,15)=7,$$VAL^XBDIQ1(9002011.65,AMHSF,1401)="" S AMHC=1 W !,"Location of Act is OTHER, OTHER description is required."
I $P(^AMHPSUIC(AMHSF,0),U,15)'=7,$$VAL^XBDIQ1(9002011.65,AMHSF,1401)]"" S DIE="^AMHPSUIC(",DA=AMHSF,DR="1401///@" D ^DIE K DA,DIE,DR
I AMHC W !!,"One or more required data elements are missing.",!! D G:Y="E" ADDDS G:Y="L" EXIT W !,"Deleting form..." S DA=AMHSF,DIK="^AMHPSUIC(" D ^DIK D PAUSE
.S DIR(0)="S^E:Edit and Complete the Form;D:Delete the Incomplete Form;L:Leave the Incomplete Form as is and Finish it Later",DIR("A")="What do you want to do",DIR("B")="E" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S Y="L"
.Q
EXIT ; -- exit code
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=AMHLINE
D HDR
K X,Y,Z,I
Q
EOJ ;
D EN^XBVK("AMH")
K DFN
K DDSFILE,DIPGM,Y
K X,Y,%,DR,DDS,DA,DIC
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
;
EXPND ; -- expand code
Q
;
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
UPI(P,D) ;
I '$G(P) Q ""
I $P($G(^AUTTSITE(1,1)),U,3)="" S $P(^AUTTSITE(1,1),U,3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)
;
Q $P(^AUTTSITE(1,1),U,3)_$E(D,4,5)_$E(D,6,7)_(1700+$E(D,1,3))_$E("0000000000",1,10-$L(P))_P
;
AV ;EP add visit
D FULL^VALM1
D GETPAT^AMHLEA
I 'AMHPAT W !,"NO Patient selected!",! D PAUSE^AMHLEA D EXIT Q
S DFN=AMHPAT
S AMHDPEEP=AMHPROV
D CONTACT^AMHLEP1(AMHPAT,1)
S AMHPROV=AMHDPEEP
D PAUSE^AMHLEA
D EXIT
Q
METHOD(VAL) ;
NEW DDH
I $G(VAL)="" Q 1
I '$G(AMHIISFE) Q 1
I '$G(AMHSF) Q 1
NEW AMHG,AMHX,AMHDA
S AMHG=0
I '$O(^AMHPSUIC(AMHSF,11,0)) Q 1
S AMHDA=0 F S AMHDA=$O(^AMHPSUIC(AMHSF,11,AMHDA)) Q:AMHDA'=+AMHDA S AMHY=$P(^AMHPSUIC(AMHSF,11,AMHDA,0),U) I AMHY'="U" S AMHG=1
I VAL="U",AMHG D Q 0
.NEW A K A
.S A(1)="You cannot enter UNKNOWN if other legitimate values have already been entered.",A(1,"F")="!"
.S A(2)="If you want to enter UNKNOWN you must first delete (using the '@') all other entries."
.D EN^DDIOL(.A)
.K A
.Q
S AMHG=0
S AMHDA=0 F S AMHDA=$O(^AMHPSUIC(AMHSF,11,AMHDA)) Q:AMHDA'=+AMHDA S AMHY=$P(^AMHPSUIC(AMHSF,11,AMHDA,0),U) I AMHY="U" S AMHG=1
I VAL'="U",AMHG D Q 0
.NEW A K A
.S A(1)="You have already entered UNKNOWN as a value. If you want to enter",A(1,"F")="!"
.S A(2)="another method you must first delete (using the '@') the UNKNOWN entry."
.D EN^DDIOL(.A)
.K A
.Q
Q 1
PS(VAL) ;
I $G(VAL)="" Q 1
I '$G(AMHIISFE) Q 1
I '$G(AMHSF) Q 1
NEW AMHG,AMHX,AMHDA
S AMHG=0
S AMHX=$P(^AMHTSCF(VAL,0),U)
I '$O(^AMHPSUIC(AMHSF,13,0)) Q 1
S AMHDA=0 F S AMHDA=$O(^AMHPSUIC(AMHSF,13,AMHDA)) Q:AMHDA'=+AMHDA S AMHY=$P(^AMHPSUIC(AMHSF,13,AMHDA,0),U) S AMHY=$P(^AMHTSCF(AMHY,0),U) I AMHY'="UNKNOWN" S AMHG=1
I AMHX="UNKNOWN",AMHG D Q 0
.NEW A K A
.S A(1)="You cannot enter UNKNOWN if other legitimate values have already been entered.",A(1,"F")="!"
.S A(2)="If you want to enter UNKNOWN you must first delete (using the '@') all other entries."
.D EN^DDIOL(.A)
.K A
.Q
S AMHG=0
S AMHDA=0 F S AMHDA=$O(^AMHPSUIC(AMHSF,13,AMHDA)) Q:AMHDA'=+AMHDA S AMHY=$P(^AMHPSUIC(AMHSF,13,AMHDA,0),U) S AMHY=$P(^AMHTSCF(AMHY,0),U) I AMHY="UNKNOWN" S AMHG=1
I AMHX'="UNKNOWN",AMHG D Q 0
.NEW A K A
.S A(1)="You have already entered UNKNOWN as a value. If you want to enter",A(1,"F")="!"
.S A(2)="another factor you must first delete (using the '@') the UNKNOWN entry."
.D EN^DDIOL(.A)
.K A
.Q
Q 1
UPDATE(V,P,E) ;EP - called from xref
I $G(V)="" Q
I $G(P)="" Q
I $G(E)="" Q
I '$D(^AMHPSUIC(E)) Q
I '$D(^AMHPSUIC(E,51,0)) S ^AMHPSUIC(E,51,0)="^9002011.6551DA^0^0"
NEW C,Z,N,G
;if this user has been logged in the past hour don't file
S (G,Z)=0 F S Z=$O(^AMHPSUIC(E,51,Z)) Q:Z'=+Z D
.S C=$P(^AMHPSUIC(E,51,Z,0),U),N=$P(^AMHPSUIC(E,51,Z,0),U,2)
.Q:N'=P
.I $$FMDIFF^XLFDT(V,C,2)<3600 S G=1
I G Q
S C=0,Z=0 F S Z=$O(^AMHPSUIC(E,51,Z)) Q:Z'=+Z S C=Z
S N=C+1
S ^AMHPSUIC(E,51,N,0)=V_"^"_P
S ^AMHPSUIC(E,51,"B",V,N)=""
S C=0,Z=0 F S Z=$O(^AMHPSUIC(E,51,Z)) Q:Z'=+Z S C=C+1
S $P(^AMHPSUIC(E,51,0),U,3)=N
S $P(^AMHPSUIC(E,51,0),U,4)=C
Q
INCOMPSF(AMHSF) ;EP - check record for completeness
NEW AMHC,G,AMHF,Z,X
S AMHC=0
S G=0 F AMHF=.03:.01:.08 I $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)="" S G=1
I G Q G
S G=0 F AMHF=.11,.13:.01:.15,.25 I $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)="" S G=1
I G Q G
I $P(^AMHPSUIC(AMHSF,0),U,15)=7,$$VAL^XBDIQ1(9002011.65,AMHSF,1401)="" S G=1
I G Q G
I $$VAL^XBDIQ1(9002011.65,AMHSF,.25)="OTHER",$$VAL^XBDIQ1(9002011.65,AMHSF,1402)="" S G=1
I G Q G
S (Z,X,G)=0 F S X=$O(^AMHPSUIC(AMHSF,11,X)) Q:X'=+X D
.I $P($G(^AMHPSUIC(AMHSF,11,X,0)),U)]"" S G=1
.I $P(^AMHPSUIC(AMHSF,11,X,0),U,1)'=7 K ^AMHPSUIC(AMHSF,11,X,11)
.Q
I 'G Q 1
S (Z,X,G)=0 F S X=$O(^AMHPSUIC(AMHSF,11,X)) Q:X'=+X D
.I $P($G(^AMHPSUIC(AMHSF,11,X,0)),U)=8,$P(^AMHPSUIC(AMHSF,11,X,0),U,2)="" S G=1
.Q
I G Q G
S (Z,X,G)=0 F S X=$O(^AMHPSUIC(AMHSF,11,X)) Q:X'=+X D
.I $P(^AMHPSUIC(AMHSF,11,X,0),U,1)=7 D
..S Y=0 F S Y=$O(^AMHPSUIC(AMHSF,11,X,11,Y)) Q:Y'=+Y D
...S D=$P(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,1)
...I $P(^AMHTSDRG(D,0),U,2),$P(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,2)="" S G=1
.Q
I G Q G
S G=$P(^AMHPSUIC(AMHSF,0),U,26)
I G="" Q 1
I G'=2 S G=0
I G=2 D
.S X=0,D=0,G=0 F S X=$O(^AMHPSUIC(AMHSF,15,X)) Q:X'=+X D
..S D=$P(^AMHPSUIC(AMHSF,15,X,0),U,1)
..I $P(^AMHTSSU(D,0),U,2),$P(^AMHPSUIC(AMHSF,15,X,0),U,2)="" S G=1
I G Q G
S (Z,G,X)=0 F S X=$O(^AMHPSUIC(AMHSF,13,X)) Q:X'=+X D
.I $P($G(^AMHPSUIC(AMHSF,13,X,0)),U)]"" S G=1
.Q
I 'G Q 1
S (Z,G,X)=0 F S X=$O(^AMHPSUIC(AMHSF,13,X)) Q:X'=+X D
.S D=$P(^AMHPSUIC(AMHSF,13,X,0),U,1)
.I $P(^AMHTSCF(D,0),U,1)="OTHER",$P(^AMHPSUIC(AMHSF,13,X,0),U,2)="" S G=1
I G Q G
Q 0
AMHLESF ; IHS/CMI/LAB - SUICIDE FORM UPDATE ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,2,6**;JUN 02, 2010;Build 10
+2 ;
+3 ;
START ;
+1 DO EN^XBVK("AMH")
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE $$CTR("Update Suicide Forms",80)
GETPAT ;
+1 SET (AMHPAT,DFN)=""
+2 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+3 IF Y<0
DO EOJ
QUIT
+4 IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
DO NALLOWP^AMHUTIL
SET DFN=""
GOTO GETPAT
+5 SET (DFN,AMHPAT)=+Y
+6 IF $GET(AUPNDOD)]""
WRITE !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!!
HANG 2
+7 WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
SET (DFN,AMHPAT)=""
DO EOJ
QUIT
+8 DO EN
END ;
+1 DO EOJ
+2 KILL AMHP,AMHQUIT,AMHW
+3 QUIT
+4 ;
EN ;EP -- main entry point
+1 NEW AMHLEAP
+2 DO EN^VALM("AMH VIEW/UPDATE SUICIDE FORM")
+3 KILL AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE,AMHF,AMHLESF,AMHDP,AMHIISFE,AMHRCNT,AMHSF
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Suicide Forms on File for: "_IORVON_$PIECE(^DPT(DFN,0),U)_IOINORM
+2 SET VALMHDR(2)="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))_" "_$$VAL^XBDIQ1(2,DFN,.02)_" DOB: "_$$DOB^AUPNPAT(DFN,"E")
+3 SET VALMHDR(3)="Tribe: "_$EXTRACT($$TRIBE^AUPNPAT(DFN,"E"),1,25)_" Community: "_$$COMMRES^AUPNPAT(DFN,"E")
+4 QUIT
+5 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
INIT ;
+1 SET VALMSG="?? for more actions + next screen - prev screen"
+2 DO GATHER
+3 SET VALMCNT=AMHLINE
+4 QUIT
+5 ;
GATHER ;
+1 KILL AMHLESF
+2 SET AMHRCNT=0
SET AMHLINE=0
+3 IF '$DATA(^AMHPSUIC("AC",DFN))
SET AMHLESF(1,0)="No Suicide Forms currently on file for "_$PIECE(^DPT(DFN,0),U)
SET AMHLESF("IDX",1,1)=""
SET AMHRCNT=1
QUIT
+4 SET AMHSD=0
FOR
SET AMHSD=$ORDER(^AMHPSUIC("AA",DFN,AMHSD))
IF AMHSD'=+AMHSD
QUIT
SET AMHSF=0
FOR
SET AMHSF=$ORDER(^AMHPSUIC("AA",DFN,AMHSD,AMHSF))
IF AMHSF'=+AMHSF
QUIT
Begin DoDot:1
+5 SET AMHRCNT=AMHRCNT+1
+6 SET X=AMHRCNT_") Local Case #: "_$PIECE(^AMHPSUIC(AMHSF,0),U,2)
SET $EXTRACT(X,35)="Computer Case #: "_$PIECE(^AMHPSUIC(AMHSF,0),U)
+7 SET AMHLINE=AMHLINE+1
SET AMHLESF(AMHLINE,0)=X
SET AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
+8 SET X=" Date of Act: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.06)
SET $EXTRACT(X,35)="Provider: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.03)
+9 SET AMHLINE=AMHLINE+1
SET AMHLESF(AMHLINE,0)=X
SET AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
+10 SET X=" Suicidal Behavior: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.131)
SET AMHLINE=AMHLINE+1
SET AMHLESF(AMHLINE,0)=X
SET AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
+11 SET Y=""
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(AMHSF,11,Z))
IF Z'=+Z
QUIT
SET Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$PIECE(^AMHPSUIC(AMHSF,11,Z,0),U))_" "
+12 SET X=" Method: "_Y
SET AMHLINE=AMHLINE+1
SET AMHLESF(AMHLINE,0)=X
SET AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
+13 IF $$INCOMPSF(AMHSF)
SET X=" "_IORVON_"[Incomplete Form]"_IOINORM
SET AMHLINE=AMHLINE+1
SET AMHLESF(AMHLINE,0)=X
SET AMHLESF("IDX",AMHLINE,AMHRCNT)=AMHSF
End DoDot:1
+14 QUIT
EDIT ;EP
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+4 SET AMHSF=0
SET (X,Y)=0
FOR
SET X=$ORDER(AMHLESF("IDX",X))
IF X'=+X!(AMHSF)
QUIT
IF $ORDER(AMHLESF("IDX",X,0))=R
SET Y=$ORDER(AMHLESF("IDX",X,0))
SET AMHSF=AMHLESF("IDX",X,Y)
+5 IF '$DATA(^AMHPSUIC(AMHSF,0))
WRITE !,"Not a valid SUICIDE RECORD."
KILL AMHRDEL,R,AMHSF,R1
DO PAUSE
DO EXIT
QUIT
+6 DO FULL^VALM1
+7 SET DA=AMHSF
SET DIE="^AMHPSUIC("
SET DR=".21////"_DT_";.22////"_DUZ_";.27////"_$$NOW^XLFDT
DO ^DIE
+8 DO ADDDS
+9 DO EXIT
+10 QUIT
DISP ;EP
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+4 SET AMHSF=0
SET (X,Y)=0
FOR
SET X=$ORDER(AMHLESF("IDX",X))
IF X'=+X!(AMHSF)
QUIT
IF $ORDER(AMHLESF("IDX",X,0))=R
SET Y=$ORDER(AMHLESF("IDX",X,0))
SET AMHSF=AMHLESF("IDX",X,Y)
+5 IF '$DATA(^AMHPSUIC(AMHSF,0))
WRITE !,"Not a valid SUICIDE RECORD."
KILL AMHRDEL,R,AMHSF,R1
DO PAUSE
DO EXIT
QUIT
+6 DO FULL^VALM1
+7 DO EP^AMHLESF1(AMHSF)
+8 DO EXIT
+9 QUIT
DEL ;EP - called from protocol
+1 IF '$DATA(^XUSEC("AMHZ DELETE RECORD",DUZ))
WRITE !!,"You do not have the security access to delete a Suicide Form.",!,"Please see your supervisor or program manager.",!
DO PAUSE
DO EXIT
QUIT
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+4 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+5 SET AMHSF=0
SET (X,Y)=0
FOR
SET X=$ORDER(AMHLESF("IDX",X))
IF X'=+X!(AMHSF)
QUIT
IF $ORDER(AMHLESF("IDX",X,0))=R
SET Y=$ORDER(AMHLESF("IDX",X,0))
SET AMHSF=AMHLESF("IDX",X,Y)
+6 IF '$DATA(^AMHPSUIC(AMHSF,0))
WRITE !,"Not a valid SUICIDE RECORD."
KILL AMHRDEL,R,AMHSF,R1
DO PAUSE
DO EXIT
QUIT
+7 DO FULL^VALM1
+8 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this suicide form"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
DO EXIT
QUIT
+10 IF 'Y
DO EXIT
QUIT
+11 SET DA=AMHSF
SET DIK="^AMHPSUIC("
DO ^DIK
+12 DO EXIT
+13 QUIT
BV ;
+1 NEW AMHPAT
+2 DO EP^AMHVD(DFN)
+3 DO EXIT
+4 QUIT
HS ;EP
+1 DO FULL^VALM1
+2 SET Y=DFN
DO ^AUPNPAT
+3 DO GETTYPE
+4 IF '$GET(APCHSTYP)
DO EN^XBVK("APCH")
QUIT
+5 SET APCHSPAT=DFN
+6 SET %="PCC Health Summary for "_$PIECE(^DPT(APCHSPAT,0),U)
+7 NEW DFN,AMHPAT
DO VIEWR^XBLM("EN^APCHS",%)
+8 DO EN^XBVK("APCH")
KILL AMCHDAYS,AMCHDOB,%
+9 DO EXIT
+10 QUIT
GETTYPE ;
+1 IF $GET(^AMHSITE(DUZ(2),0))=""
DO DEFAULT
QUIT
+2 SET APCHSTYP=$PIECE(^AMHSITE(DUZ(2),0),U,4)
IF APCHSTYP=""
DO DEFAULT
QUIT
+3 IF '$DATA(^APCHSCTL(APCHSTYP))
WRITE !,"Error in Site Parameter File!",$CHAR(7),$CHAR(7)
SET APCHSTYP=""
QUIT
+4 QUIT
DEFAULT ;
+1 SET APCHSTYP=""
+2 SET X="BEHAVIORAL HEALTH"
SET DIC(0)=""
SET DIC="^APCHSCTL("
DO ^DIC
KILL DIC,DA
+3 IF Y=-1
WRITE !!,"PCC MENTAL HEALTH HEALTH SUMMARY TYPE IS MISSING!! NOTIFY YOUR SUPERVISOR OR SITE MANAGER.",!!
QUIT
+4 SET APCHSTYP=+Y
+5 QUIT
ADDSF(AMHPAT) ;EP
+1 DO FULL^VALM1
+2 IF $DATA(IOF)
WRITE @IOF
PROV ;
+1 DO ^XBFMK
+2 SET AMHDP=""
+3 WRITE !!
SET DIC("A")="Provider Completing the Form: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("B")=$PIECE(^VA(200,DUZ,0),U)
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+4 IF Y<0
WRITE !,"No Provider Selected."
DO EXIT
QUIT
+5 SET AMHPROV=+Y
GETDATE ;EP
+1 WRITE !!
+2 SET AMHDATE=""
SET DIR(0)="DO^:"_DT_":EPTX"
SET DIR("A")="Enter the DATE of the SUICIDE ACT"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
DO EXIT
GOTO PROV
+4 SET AMHDATE=Y
+5 SET X=0
SET G=0
SET Y=0
SET Q=0
FOR
SET X=$ORDER(^AMHPSUIC("AC",DFN,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^AMHPSUIC(X,0),U,6)=AMHDATE
Begin DoDot:1
+6 SET Y=1
WRITE !!,"This patient already has a suicide form on file for this Date of Act."
+7 WRITE !,"The form was filled out by: ",$$VAL^XBDIQ1(9002011.65,X,.03),!
+8 SET DIR(0)="S^A:Continue to ADD a new form;Q:Quit - do not add a new form"
SET DIR("A")="Do you wish to"
SET DIR("B")="Q"
KILL DA
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
SET Y="Q"
QUIT
+10 IF Y="Q"
QUIT
+11 SET G=1
End DoDot:1
+12 IF Y="Q"
DO PAUSE
DO EXIT
QUIT
+13 KILL DD,D0,DO,DINUM,DIC,DA,DR
SET DIC(0)="EL"
SET DIC="^AMHPSUIC("
SET DLAYGO=9002011.65
SET DIADD=1
SET X=$$UPI(AMHPAT,AMHDATE)
+14 SET DIC("DR")=".06////"_AMHDATE_";.04////"_AMHPAT_";.03////"_AMHPROV_";.18////"_DT_";.19////"_DUZ_";.21////"_DT_";.22////"_DUZ_";.27////"_$$NOW^XLFDT
+15 SET DIC("DR")=DIC("DR")_";9901///1"
+16 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+17 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Error creating Suicide form!! Deleting form.",!
DO PAUSE
DO EXIT
QUIT
+18 SET AMHSF=+Y
+19 DO ADDDS
+20 DO EXIT
+21 QUIT
ADDDS ;
+1 SET AMHIISFE=1
+2 SET DA=AMHSF
SET DDSFILE=9002011.65
SET DR="[AMH SUICIDE FORM UPDATE]"
DO ^DDS
+3 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
DO PAUSE
DO EXIT
QUIT
+4 DO CHECK
+5 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
CHECK ; check record for completeness
+1 SET AMHC=0
+2 FOR AMHF=.03:.01:.08
IF $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)=""
WRITE !,$PIECE(^DD(9002011.65,AMHF,0),U)," is a required data element."
SET AMHC=1
+3 FOR AMHF=.11,.13:.01:.15,.25
IF $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)=""
WRITE !,$PIECE(^DD(9002011.65,AMHF,0),U)," is a required data element."
SET AMHC=1
+4 IF $$VAL^XBDIQ1(9002011.65,AMHSF,.25)="OTHER"
IF $$VAL^XBDIQ1(9002011.65,AMHSF,1402)=""
SET AMHC=1
WRITE !,"Location of Act is OTHER, OTHER description is required."
+5 IF $$VAL^XBDIQ1(9002011.65,AMHSF,.25)'="OTHER"
IF $$VAL^XBDIQ1(9002011.65,AMHSF,1402)]""
SET DA=AMHSF
SET DIE="^AMHPSUIC("
SET DR="1402///@"
DO ^DIE
KILL DA,DIE,DR
+6 SET (Z,X,G)=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,11,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^AMHPSUIC(AMHSF,11,X,0)),U)]""
SET G=1
+8 IF $PIECE($GET(^AMHPSUIC(AMHSF,11,X,0)),U)=8
IF $PIECE(^AMHPSUIC(AMHSF,11,X,0),U,2)=""
WRITE !,"One of the Methods is OTHER. OTHER description is Required."
SET AMHC=1
+9 IF $PIECE(^AMHPSUIC(AMHSF,11,X,0),U,1)'=7
KILL ^AMHPSUIC(AMHSF,11,X,11)
+10 IF $PIECE(^AMHPSUIC(AMHSF,11,X,0),U,1)=7
Begin DoDot:2
+11 SET Y=0
FOR
SET Y=$ORDER(^AMHPSUIC(AMHSF,11,X,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+12 SET D=$PIECE(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,1)
+13 IF $PIECE(^AMHTSDRG(D,0),U,2)
IF $PIECE(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,2)=""
SET AMHC=1
WRITE !,"Method is Overdose, Drug type is Other, Other description is required."
End DoDot:3
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF 'G
WRITE !!,"You must enter a METHOD."
SET AMHC=1
+16 SET G=$PIECE(^AMHPSUIC(AMHSF,0),U,26)
+17 IF G=""
WRITE !!,"You must enter a value for SUBSTANCE Use. None or Unknown are valid values."
SET AMHC=1
+18 IF G=2
Begin DoDot:1
+19 SET X=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,15,X))
IF X'=+X
QUIT
Begin DoDot:2
+20 SET D=$PIECE(^AMHPSUIC(AMHSF,15,X,0),U,1)
+21 IF $PIECE(^AMHTSSU(D,0),U,2)
IF $PIECE(^AMHPSUIC(AMHSF,15,X,0),U,2)=""
SET AMHC=1
WRITE !,"Substance Involved is Alcohol/Drugs, Drug is Other, Other Description is Required."
End DoDot:2
End DoDot:1
+22 SET (Z,G,X)=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,13,X))
IF X'=+X
QUIT
Begin DoDot:1
+23 IF $PIECE($GET(^AMHPSUIC(AMHSF,13,X,0)),U)]""
SET G=1
+24 SET D=$PIECE(^AMHPSUIC(AMHSF,13,X,0),U,1)
+25 IF $PIECE(^AMHTSCF(D,0),U,1)="OTHER"
IF $PIECE(^AMHPSUIC(AMHSF,13,X,0),U,2)=""
SET AMHC=1
WRITE !,"Contributing Factor is OTHER, OTHER description is required."
+26 QUIT
End DoDot:1
+27 ;NOW CHECK FOR OTHER
+28 IF 'G
WRITE !!,"You must enter a CONTRIBUTING FACTOR. Unknown is a valid value."
SET AMHC=1
+29 IF $PIECE(^AMHPSUIC(AMHSF,0),U,15)=7
IF $$VAL^XBDIQ1(9002011.65,AMHSF,1401)=""
SET AMHC=1
WRITE !,"Location of Act is OTHER, OTHER description is required."
+30 IF $PIECE(^AMHPSUIC(AMHSF,0),U,15)'=7
IF $$VAL^XBDIQ1(9002011.65,AMHSF,1401)]""
SET DIE="^AMHPSUIC("
SET DA=AMHSF
SET DR="1401///@"
DO ^DIE
KILL DA,DIE,DR
+31 IF AMHC
WRITE !!,"One or more required data elements are missing.",!!
Begin DoDot:1
+32 SET DIR(0)="S^E:Edit and Complete the Form;D:Delete the Incomplete Form;L:Leave the Incomplete Form as is and Finish it Later"
SET DIR("A")="What do you want to do"
SET DIR("B")="E"
KILL DA
DO ^DIR
KILL DIR
+33 IF $DATA(DIRUT)
SET Y="L"
+34 QUIT
End DoDot:1
IF Y="E"
GOTO ADDDS
IF Y="L"
GOTO EXIT
WRITE !,"Deleting form..."
SET DA=AMHSF
SET DIK="^AMHPSUIC("
DO ^DIK
DO PAUSE
EXIT ; -- exit code
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER
+4 SET VALMCNT=AMHLINE
+5 DO HDR
+6 KILL X,Y,Z,I
+7 QUIT
EOJ ;
+1 DO EN^XBVK("AMH")
+2 KILL DFN
+3 KILL DDSFILE,DIPGM,Y
+4 KILL X,Y,%,DR,DDS,DA,DIC
+5 IF $DATA(VALMWD)
DO CLEAR^VALM1
+6 KILL VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
+7 DO KILL^AUPNPAT
+8 QUIT
+9 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
UPI(P,D) ;
+1 IF '$GET(P)
QUIT ""
+2 IF $PIECE($GET(^AUTTSITE(1,1)),U,3)=""
SET $PIECE(^AUTTSITE(1,1),U,3)=$PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0),U,10)
+3 ;
+4 QUIT $PIECE(^AUTTSITE(1,1),U,3)_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)_(1700+$EXTRACT(D,1,3))_$EXTRACT("0000000000",1,10-$LENGTH(P))_P
+5 ;
AV ;EP add visit
+1 DO FULL^VALM1
+2 DO GETPAT^AMHLEA
+3 IF 'AMHPAT
WRITE !,"NO Patient selected!",!
DO PAUSE^AMHLEA
DO EXIT
QUIT
+4 SET DFN=AMHPAT
+5 SET AMHDPEEP=AMHPROV
+6 DO CONTACT^AMHLEP1(AMHPAT,1)
+7 SET AMHPROV=AMHDPEEP
+8 DO PAUSE^AMHLEA
+9 DO EXIT
+10 QUIT
METHOD(VAL) ;
+1 NEW DDH
+2 IF $GET(VAL)=""
QUIT 1
+3 IF '$GET(AMHIISFE)
QUIT 1
+4 IF '$GET(AMHSF)
QUIT 1
+5 NEW AMHG,AMHX,AMHDA
+6 SET AMHG=0
+7 IF '$ORDER(^AMHPSUIC(AMHSF,11,0))
QUIT 1
+8 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AMHPSUIC(AMHSF,11,AMHDA))
IF AMHDA'=+AMHDA
QUIT
SET AMHY=$PIECE(^AMHPSUIC(AMHSF,11,AMHDA,0),U)
IF AMHY'="U"
SET AMHG=1
+9 IF VAL="U"
IF AMHG
Begin DoDot:1
+10 NEW A
KILL A
+11 SET A(1)="You cannot enter UNKNOWN if other legitimate values have already been entered."
SET A(1,"F")="!"
+12 SET A(2)="If you want to enter UNKNOWN you must first delete (using the '@') all other entries."
+13 DO EN^DDIOL(.A)
+14 KILL A
+15 QUIT
End DoDot:1
QUIT 0
+16 SET AMHG=0
+17 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AMHPSUIC(AMHSF,11,AMHDA))
IF AMHDA'=+AMHDA
QUIT
SET AMHY=$PIECE(^AMHPSUIC(AMHSF,11,AMHDA,0),U)
IF AMHY="U"
SET AMHG=1
+18 IF VAL'="U"
IF AMHG
Begin DoDot:1
+19 NEW A
KILL A
+20 SET A(1)="You have already entered UNKNOWN as a value. If you want to enter"
SET A(1,"F")="!"
+21 SET A(2)="another method you must first delete (using the '@') the UNKNOWN entry."
+22 DO EN^DDIOL(.A)
+23 KILL A
+24 QUIT
End DoDot:1
QUIT 0
+25 QUIT 1
PS(VAL) ;
+1 IF $GET(VAL)=""
QUIT 1
+2 IF '$GET(AMHIISFE)
QUIT 1
+3 IF '$GET(AMHSF)
QUIT 1
+4 NEW AMHG,AMHX,AMHDA
+5 SET AMHG=0
+6 SET AMHX=$PIECE(^AMHTSCF(VAL,0),U)
+7 IF '$ORDER(^AMHPSUIC(AMHSF,13,0))
QUIT 1
+8 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AMHPSUIC(AMHSF,13,AMHDA))
IF AMHDA'=+AMHDA
QUIT
SET AMHY=$PIECE(^AMHPSUIC(AMHSF,13,AMHDA,0),U)
SET AMHY=$PIECE(^AMHTSCF(AMHY,0),U)
IF AMHY'="UNKNOWN"
SET AMHG=1
+9 IF AMHX="UNKNOWN"
IF AMHG
Begin DoDot:1
+10 NEW A
KILL A
+11 SET A(1)="You cannot enter UNKNOWN if other legitimate values have already been entered."
SET A(1,"F")="!"
+12 SET A(2)="If you want to enter UNKNOWN you must first delete (using the '@') all other entries."
+13 DO EN^DDIOL(.A)
+14 KILL A
+15 QUIT
End DoDot:1
QUIT 0
+16 SET AMHG=0
+17 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AMHPSUIC(AMHSF,13,AMHDA))
IF AMHDA'=+AMHDA
QUIT
SET AMHY=$PIECE(^AMHPSUIC(AMHSF,13,AMHDA,0),U)
SET AMHY=$PIECE(^AMHTSCF(AMHY,0),U)
IF AMHY="UNKNOWN"
SET AMHG=1
+18 IF AMHX'="UNKNOWN"
IF AMHG
Begin DoDot:1
+19 NEW A
KILL A
+20 SET A(1)="You have already entered UNKNOWN as a value. If you want to enter"
SET A(1,"F")="!"
+21 SET A(2)="another factor you must first delete (using the '@') the UNKNOWN entry."
+22 DO EN^DDIOL(.A)
+23 KILL A
+24 QUIT
End DoDot:1
QUIT 0
+25 QUIT 1
UPDATE(V,P,E) ;EP - called from xref
+1 IF $GET(V)=""
QUIT
+2 IF $GET(P)=""
QUIT
+3 IF $GET(E)=""
QUIT
+4 IF '$DATA(^AMHPSUIC(E))
QUIT
+5 IF '$DATA(^AMHPSUIC(E,51,0))
SET ^AMHPSUIC(E,51,0)="^9002011.6551DA^0^0"
+6 NEW C,Z,N,G
+7 ;if this user has been logged in the past hour don't file
+8 SET (G,Z)=0
FOR
SET Z=$ORDER(^AMHPSUIC(E,51,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+9 SET C=$PIECE(^AMHPSUIC(E,51,Z,0),U)
SET N=$PIECE(^AMHPSUIC(E,51,Z,0),U,2)
+10 IF N'=P
QUIT
+11 IF $$FMDIFF^XLFDT(V,C,2)<3600
SET G=1
End DoDot:1
+12 IF G
QUIT
+13 SET C=0
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(E,51,Z))
IF Z'=+Z
QUIT
SET C=Z
+14 SET N=C+1
+15 SET ^AMHPSUIC(E,51,N,0)=V_"^"_P
+16 SET ^AMHPSUIC(E,51,"B",V,N)=""
+17 SET C=0
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(E,51,Z))
IF Z'=+Z
QUIT
SET C=C+1
+18 SET $PIECE(^AMHPSUIC(E,51,0),U,3)=N
+19 SET $PIECE(^AMHPSUIC(E,51,0),U,4)=C
+20 QUIT
INCOMPSF(AMHSF) ;EP - check record for completeness
+1 NEW AMHC,G,AMHF,Z,X
+2 SET AMHC=0
+3 SET G=0
FOR AMHF=.03:.01:.08
IF $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)=""
SET G=1
+4 IF G
QUIT G
+5 SET G=0
FOR AMHF=.11,.13:.01:.15,.25
IF $$VAL^XBDIQ1(9002011.65,AMHSF,AMHF)=""
SET G=1
+6 IF G
QUIT G
+7 IF $PIECE(^AMHPSUIC(AMHSF,0),U,15)=7
IF $$VAL^XBDIQ1(9002011.65,AMHSF,1401)=""
SET G=1
+8 IF G
QUIT G
+9 IF $$VAL^XBDIQ1(9002011.65,AMHSF,.25)="OTHER"
IF $$VAL^XBDIQ1(9002011.65,AMHSF,1402)=""
SET G=1
+10 IF G
QUIT G
+11 SET (Z,X,G)=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,11,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF $PIECE($GET(^AMHPSUIC(AMHSF,11,X,0)),U)]""
SET G=1
+13 IF $PIECE(^AMHPSUIC(AMHSF,11,X,0),U,1)'=7
KILL ^AMHPSUIC(AMHSF,11,X,11)
+14 QUIT
End DoDot:1
+15 IF 'G
QUIT 1
+16 SET (Z,X,G)=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,11,X))
IF X'=+X
QUIT
Begin DoDot:1
+17 IF $PIECE($GET(^AMHPSUIC(AMHSF,11,X,0)),U)=8
IF $PIECE(^AMHPSUIC(AMHSF,11,X,0),U,2)=""
SET G=1
+18 QUIT
End DoDot:1
+19 IF G
QUIT G
+20 SET (Z,X,G)=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,11,X))
IF X'=+X
QUIT
Begin DoDot:1
+21 IF $PIECE(^AMHPSUIC(AMHSF,11,X,0),U,1)=7
Begin DoDot:2
+22 SET Y=0
FOR
SET Y=$ORDER(^AMHPSUIC(AMHSF,11,X,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+23 SET D=$PIECE(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,1)
+24 IF $PIECE(^AMHTSDRG(D,0),U,2)
IF $PIECE(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,2)=""
SET G=1
End DoDot:3
End DoDot:2
+25 QUIT
End DoDot:1
+26 IF G
QUIT G
+27 SET G=$PIECE(^AMHPSUIC(AMHSF,0),U,26)
+28 IF G=""
QUIT 1
+29 IF G'=2
SET G=0
+30 IF G=2
Begin DoDot:1
+31 SET X=0
SET D=0
SET G=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,15,X))
IF X'=+X
QUIT
Begin DoDot:2
+32 SET D=$PIECE(^AMHPSUIC(AMHSF,15,X,0),U,1)
+33 IF $PIECE(^AMHTSSU(D,0),U,2)
IF $PIECE(^AMHPSUIC(AMHSF,15,X,0),U,2)=""
SET G=1
End DoDot:2
End DoDot:1
+34 IF G
QUIT G
+35 SET (Z,G,X)=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,13,X))
IF X'=+X
QUIT
Begin DoDot:1
+36 IF $PIECE($GET(^AMHPSUIC(AMHSF,13,X,0)),U)]""
SET G=1
+37 QUIT
End DoDot:1
+38 IF 'G
QUIT 1
+39 SET (Z,G,X)=0
FOR
SET X=$ORDER(^AMHPSUIC(AMHSF,13,X))
IF X'=+X
QUIT
Begin DoDot:1
+40 SET D=$PIECE(^AMHPSUIC(AMHSF,13,X,0),U,1)
+41 IF $PIECE(^AMHTSCF(D,0),U,1)="OTHER"
IF $PIECE(^AMHPSUIC(AMHSF,13,X,0),U,2)=""
SET G=1
End DoDot:1
+42 IF G
QUIT G
+43 QUIT 0
