- 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