Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHSFR

AMHSFR.m

Go to the documentation of this file. 
  1. AMHSFR ; IHS/CMI/LAB - REVIEW SF BY DATE 28 Apr 2009 10:46 AM ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**1,2**;JUN 18, 2010;Build 23
  1.  ;
  1.  ;
  1. START ;
  1.  W:$D(IOF) @IOF
  1.  W $$CTR("Review/Update Suicide Forms by Date",80)
  1.  D DONE
  1.  ;
  1. D ;date range
  1.  K AMHED,AMHBD
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Suicide form date"
  1.  D ^DIR S:Y<1 AMHQUIT=1 Q:Y<1  S AMHBD=Y
  1.  K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Suicide form date"
  1.  D ^DIR S:Y<1 AMHQUIT=1 Q:Y<1  S AMHED=Y
  1.  ;
  1.  I AMHED<AMHBD D  G D
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1. DEMO ;
  1.  D DEMOCHK^AMHUTIL1(.AMHDEMO)
  1.  I AMHDEMO=-1 G D
  1.  D EN,FULL^VALM1,EXIT
  1.  Q
  1. DONE ;
  1.  D EN^XBVK("AMH")
  1.  D ^XBFMK
  1.  D KILL^AUPNPAT
  1.  Q
  1. EN ;
  1.  K AMHSFR
  1.  D GATHER
  1.  D EN^VALM("AMH SF BY DATE")
  1.  D CLEAR^VALM1
  1.  Q
  1. GATHER ;
  1.  K AMHSFR
  1.  S AMHLINE=0
  1.  S AMHSD=$$FMADD^XLFDT(AMHED,1),AMHSD=9999999-AMHSD
  1.  F  S AMHSD=$O(^AMHPSUIC("AB",AMHSD)) Q:AMHSD'=+AMHSD!(AMHSD>(9999999-AMHBD))  D
  1.  .S AMHX=0 F  S AMHX=$O(^AMHPSUIC("AB",AMHSD,AMHX)) Q:AMHX'=+AMHX  D
  1.  ..S DFN=$P(^AMHPSUIC(AMHX,0),U,4),AMHDOB=$P(^DPT(DFN,0),U,3)
  1.  ..Q:'$$ALLOW(DUZ,AMHX)
  1.  ..Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
  1.  ..S AMHD=$P(^AMHPSUIC(AMHX,0),U,6)
  1.  ..S AMHLINE=AMHLINE+1,X=AMHLINE_")",$E(X,$S($L(AMHLINE)<3:5,1:6))=$S($$INCOMPSF^AMHLESF(AMHX):"I",1:"")
  1.  ..S $E(X,8)=$E(AMHD,4,5)_"/"_$E(AMHD,6,7)_"/"_$E(AMHD,2,3),$E(X,17)=$E($P(^DPT(DFN,0),U),1,19),$E(X,37)=$$HRN^AUPNPAT(DFN,DUZ(2)),$E(X,44)=$E(AMHDOB,4,5)_"/"_$E(AMHDOB,6,7)_"/"_$E(AMHDOB,2,3)
  1.  ..S $E(X,53)=$E($$VAL^XBDIQ1(9002011.65,AMHX,.131),1,20),$E(X,74)=$$VAL^XBDIQ1(9002011.65,AMHX,.031)
  1.  ..S $E(X,78)=$$VAL^XBDIQ1(9002011.65,AMHX,.02),$E(X,96)=$$VAL^XBDIQ1(9002011.65,AMHX,.01)
  1.  ..S AMHSFR(AMHLINE,0)=X,AMHSFR("IDX",AMHLINE,AMHLINE)=AMHX
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. HDR ; -- header code
  1.  S VALMHDR(1)="Suicide Form Review: "_$$FMTE^XLFDT(AMHBD)_" - "_$$FMTE^XLFDT(AMHED)
  1.  S VALMHDR(2)="I = Incomplete Form"
  1.  S X="",$E(X,8)="Date",$E(X,53)="" S VALMHDR(3)=X
  1.  S X="",X="No.",$E(X,8)="of Act",$E(X,17)="Patient",$E(X,37)="HRN",$E(X,44)="DOB",$E(X,53)="Suicidal Behavior",$E(X,74)="PRV",$E(X,78)="Local Case #",$E(X,96)="Case #",VALMHDR(4)=X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  D GATHER
  1.  S VALMCNT=AMHLINE
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1. EDIT ;EP - called from protocol
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." D EXIT Q
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
  1.  S AMHSF=0 S AMHSF=AMHSFR("IDX",R,R)
  1.  I '$D(^AMHPSUIC(AMHSF,0)) W !,"Not a valid SUICIDE RECORD." K AMHRDEL,R,AMHSF,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1. DGSECE ;
  1.  I '$P(^AMHPSUIC(AMHSF,0),U,4) G EDITR9
  1.  S AMHPAT=$P(^AMHPSUIC(AMHSF,0),U,4)
  1.  D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,0)
  1.  I '$G(AMHRESU(1)) G EDITR9
  1.  D DISPDG^AMHLE
  1.  W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue to edit this suicide form",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y D EXIT Q
  1.  K AMHRESU
  1.  D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
  1. EDITR9 ;
  1.  S DA=AMHSF,DIE="^AMHPSUIC(",DR=".21////"_DT_";.22////"_DUZ_";.27////"_$$NOW^XLFDT D ^DIE
  1.  S (AMHPAT,DFN)=$P(^AMHPSUIC(AMHSF,0),U,4)
  1.  D ADDDS
  1.  D EXIT
  1.  Q
  1. DISP ;EP - called from protocol
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." D EXIT Q
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
  1.  S AMHSF=0 S AMHSF=AMHSFR("IDX",R,R)
  1.  I '$D(^AMHPSUIC(AMHSF,0)) W !,"Not a valid SUICIDE RECORD." K AMHRDEL,R,AMHSF,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1. DGSECD ;
  1.  I '$P(^AMHPSUIC(AMHSF,0),U,4) G EDITD9
  1.  S AMHPAT=$P(^AMHPSUIC(AMHSF,0),U,4)
  1.  D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,0)
  1.  I '$G(AMHRESU(1)) G EDITD9
  1.  D DISPDG^AMHLE
  1.  W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue to display this suicide form",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y D EXIT Q
  1.  K AMHRESU
  1.  D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
  1. EDITD9 ;
  1.  ;NEW DFN,AMHPAT
  1.  D EP^AMHLESF1(AMHSF)
  1.  D EXIT
  1.  Q
  1. DEL ;EP - called from protocol
  1.  ;add code to not allow delete unless they have the key
  1.  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
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." D EXIT Q
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
  1.  S AMHSF=0 S AMHSF=AMHSFR("IDX",R,R)
  1.  I '$D(^AMHPSUIC(AMHSF,0)) W !,"Not a valid SUICIDE RECORD." K AMHRDEL,R,AMHSF,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1. DGSECX ;
  1.  I '$P(^AMHPSUIC(AMHSF,0),U,4) G EDITX9
  1.  S AMHPAT=$P(^AMHPSUIC(AMHSF,0),U,4)
  1.  D PTSEC^AMHUTIL2(.AMHRESU,AMHPAT,0)
  1.  I '$G(AMHRESU(1)) G EDITX9
  1.  D DISPDG^AMHLE
  1.  W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to continue to delete this suicide form",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y D EXIT Q
  1.  K AMHRESU
  1.  D NOTICE^DGSEC4(.AMHRESU,AMHPAT,,3)
  1. EDITX9 ;
  1.  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
  1.  I $D(DIRUT) D EXIT Q
  1.  I 'Y D EXIT Q
  1.  S DA=AMHSF,DIK="^AMHPSUIC(" D ^DIK
  1.  D EXIT
  1.  Q
  1. BV ;
  1.  ;S DFN=AMHPAT
  1.  NEW AMHPAT
  1.  D EP^AMHVD(DFN)
  1.  D EXIT
  1.  Q
  1. HS ;EP called from protocol to generate hs
  1.  D FULL^VALM1
  1.  S Y=DFN D ^AUPNPAT
  1.  D GETTYPE
  1.  I '$G(APCHSTYP) D EN^XBVK("APCH") Q
  1.  S APCHSPAT=DFN
  1.  S %="PCC Health Summary for "_$P(^DPT(APCHSPAT,0),U)
  1.  NEW DFN,AMHPAT D VIEWR^XBLM("EN^APCHS",%)
  1.  D EN^XBVK("APCH") K AMCHDAYS,AMCHDOB,%
  1.  D EXIT
  1.  Q
  1. GETTYPE ;
  1.  I $G(^AMHSITE(DUZ(2),0))="" D DEFAULT Q
  1.  S APCHSTYP=$P(^AMHSITE(DUZ(2),0),U,4) I APCHSTYP="" D DEFAULT Q
  1.  I '$D(^APCHSCTL(APCHSTYP)) W !,"Error in Site Parameter File!",$C(7),$C(7) S APCHSTYP="" Q
  1.  Q
  1. DEFAULT ;
  1.  S APCHSTYP=""
  1.  S X="BEHAVIORAL HEALTH",DIC(0)="",DIC="^APCHSCTL(" D ^DIC K DIC,DA
  1.  I Y=-1 W !!,"PCC MENTAL HEALTH HEALTH SUMMARY TYPE IS MISSING!!  NOTIFY YOUR SUPERVISOR OR SITE MANAGER.",!! Q
  1.  S APCHSTYP=+Y
  1.  Q
  1. ADD ;EP
  1.  D FULL^VALM1
  1.  S AMHPAT=""
  1.  D GETPAT^AMHLEA
  1.  I 'AMHPAT W !!,"No patient entered..." D EXIT Q
  1.  S Y=AMHPAT D ^AUPNPAT
  1.  S DFN=AMHPAT
  1.  D ADDSF(AMHPAT)
  1.  D CLEAR^VALM1
  1.  D EXIT
  1.  Q
  1. ADDSF(AMHPAT) ;EP called from protocol to add a new form
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1. PROV ;
  1.  D ^XBFMK
  1.  S AMHDP=""
  1.  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
  1.  I Y<0 W !,"No Provider Selected." D EXIT Q
  1.  S AMHPROV=+Y
  1. GETDATE ;EP - GET DATE OF ENCOUNTER
  1.  W !!
  1.  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
  1.  I $D(DIRUT) D EXIT G PROV
  1.  S AMHDATE=Y
  1.  S X=0,G=0,Y=0 F  S X=$O(^AMHPSUIC("AC",AMHPAT,X)) Q:X'=+X!(G)  I $P(^AMHPSUIC(X,0),U,6)=AMHDATE D
  1.  .S Y=1 W !!,"This patient already has a suicide form on file for this Date of Act."
  1.  .W !,"The form was filled out by:   ",$$VAL^XBDIQ1(9002011.65,X,.03),!
  1.  .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
  1.  .I $D(DIRUT) S Y="Q" Q
  1.  .I Y="Q" Q
  1.  .S G=1
  1.  I Y="Q" D PAUSE,EXIT Q
  1.  K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHPSUIC(",DLAYGO=9002011.65,DIADD=1,X=$$UPI(AMHPAT,AMHDATE)
  1.  S DIC("DR")=".06////"_AMHDATE_";.04////"_AMHPAT_";.03////"_AMHPROV_";.18////"_DT_";.19////"_DUZ_";.21////"_DT_";.22////"_DUZ_";.27////"_$$NOW^XLFDT
  1.  S DIC("DR")=DIC("DR")_";9901///1"
  1.  D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
  1.  I Y=-1 W !!,$C(7),$C(7),"Error creating Suicide form!! Deleting form.",! D PAUSE,EXIT Q
  1.  S AMHSF=+Y
  1.  D ADDDS
  1.  D EXIT
  1.  Q
  1. ADDDS ;screenman call
  1.  S AMHIISFE=1
  1.  S DA=AMHSF,DDSFILE=9002011.65,DR="[AMH SUICIDE FORM UPDATE]" D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG D PAUSE,EXIT Q
  1.  D CHECK
  1.  Q
  1.  ;
  1. CHECK ; check record for completeness
  1.  S AMHC=0
  1.  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
  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
  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."
  1.  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
  1.  ;I $P(^AMHPSUIC(AMHSF,0),U,16)="",$P(^AMHPSUIC(AMHSF,0),U,17)="" W !,"INTERVENTION is a required data element." S AMHC=1
  1.  S (Z,X,G)=0 F  S X=$O(^AMHPSUIC(AMHSF,11,X)) Q:X'=+X  D
  1.  .I $P($G(^AMHPSUIC(AMHSF,11,X,0)),U)]"" S G=1
  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
  1.  .I $P(^AMHPSUIC(AMHSF,11,X,0),U,1)'=7 K ^AMHPSUIC(AMHSF,11,X,11)
  1.  .I $P(^AMHPSUIC(AMHSF,11,X,0),U,1)=7 D
  1.  ..S Y=0 F  S Y=$O(^AMHPSUIC(AMHSF,11,X,11,Y)) Q:Y'=+Y  D
  1.  ...S D=$P(^AMHPSUIC(AMHSF,11,X,11,Y,0),U,1)
  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."
  1.  .Q
  1.  I 'G W !!,"You must enter a METHOD." S AMHC=1
  1.  S G=$P(^AMHPSUIC(AMHSF,0),U,26)
  1.  I G="" W !!,"You must enter a value for SUBSTANCE Use.  None or Unknown are valid values." S AMHC=1
  1.  I G=2 D
  1.  .S X=0 F  S X=$O(^AMHPSUIC(AMHSF,15,X)) Q:X'=+X  D
  1.  ..S D=$P(^AMHPSUIC(AMHSF,15,X,0),U,1)
  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."
  1.  S (Z,G,X)=0 F  S X=$O(^AMHPSUIC(AMHSF,13,X)) Q:X'=+X  D
  1.  .I $P($G(^AMHPSUIC(AMHSF,13,X,0)),U)]"" S G=1
  1.  .S D=$P(^AMHPSUIC(AMHSF,13,X,0),U,1)
  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."
  1.  .Q
  1.  ;NOW CHECK FOR OTHER
  1.  I 'G W !!,"You must enter a CONTRIBUTING FACTOR.  Unknown is a valid value." S AMHC=1
  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."
  1.  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
  1.  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
  1.  .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
  1.  .I $D(DIRUT) S Y="L"
  1.  .Q
  1. EXIT ; -- exit code
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D GATHER
  1.  S VALMCNT=AMHLINE
  1.  D HDR
  1.  K X,Y,Z,I,AMHPAT,DFN,AMHX,AMHLINE,AMHSF,AMHF,AMHC,AMHRESU
  1.  D KILL^AUPNPAT
  1.  Q
  1. EOJ ;
  1.  D EN^XBVK("AMH")
  1.  K DFN
  1.  K DDSFILE,DIPGM,Y
  1.  K X,Y,%,DR,DDS,DA,DIC
  1.  D:$D(VALMWD) CLEAR^VALM1
  1.  K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
  1.  D KILL^AUPNPAT
  1.  Q
  1.  ;
  1.  ;
  1. PAUSE ;EP
  1.  S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. UPI(P,D) ;EP
  1.  I '$G(P) Q ""
  1.  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)
  1.  ;
  1.  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
  1.  ;
  1. ALLOW(S,R) ;EP - CAN THIS USER SEE THIS SUICIDE FORM?
  1.  ;S is duz, R is suicide form ien
  1.  Q 1
  1.  I '$G(S) Q 0
  1.  I '$G(R) Q 0
  1.  I '$D(^AMHPSUIC(R,0)) Q 0
  1.  NEW P
  1.  S P=$P($G(^AMHPSUIC(R,0)),U,4)
  1.  I 'P Q 0
  1.  I $D(^AMHSITE(DUZ(2),16,S)) Q $$ALLOWP^AMHUTIL(S,P)  ;allow all with access
  1.  I $P(^AMHPSUIC(R,0),U,3)=S Q $$ALLOWP^AMHUTIL(S,P)   ;allow your own
  1.  Q 0