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

APCDLESF.m

Go to the documentation of this file. 
  1. APCDLESF ; IHS/CMI/LAB - SUICIDE FORM UPDATE ;
  1.  ;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009
  1.  ;
  1.  ;
  1. START ;
  1.  D EN^XBVK("APCD")
  1.  W:$D(IOF) @IOF
  1.  W $$CTR("Update Suicide Forms",80)
  1. GETPAT ;
  1.  S (APCDPAT,DFN)=""
  1.  I '$P($G(^APCDSITE(DUZ(2),0)),U,34) S AUPNLK("INAC")=1
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
  1.  I Y<0 G END
  1.  W !?25,"Ok" S %=1 D YN^DICN Q:%'=1
  1.  S (DFN,APCDPAT)=+Y
  1.  D INAC^APCDEA(APCDPAT,.X) I 'X S APCDPAT="" G GETPAT
  1.  D EN
  1. END ;
  1.  D EOJ
  1.  K APCDP,APCDQUIT,APCDW
  1.  Q
  1.  ;
  1. EN ; --
  1.  NEW APCDLEAP
  1.  D EN^VALM("APCD SUICIDE VIEW/UPDATE")
  1.  K APCDCASE,APCDX,APCDD,APCDRCNT,APCDLINE,APCDDATE
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)="Suicide Reporting Forms on File for: "_IORVON_$P(^DPT(DFN,0),U)_IOINORM
  1.  S VALMHDR(2)="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))_"    "_$$VAL^XBDIQ1(2,DFN,.02)_"   DOB: "_$$DOB^AUPNPAT(DFN,"E")
  1.  S VALMHDR(3)="Tribe: "_$E($$TRIBE^AUPNPAT(DFN,"E"),1,25)_"  Community: "_$$COMMRES^AUPNPAT(DFN,"E")
  1.  Q
  1.  ;
  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. INIT ; -- init variables and list array
  1.  S VALMSG="?? for more actions  + next screen  - prev screen"
  1.  D GATHER ;gather up all records for display
  1.  S VALMCNT=APCDLINE
  1.  Q
  1.  ;
  1. GATHER ;
  1.  K APCDLESF
  1.  S APCDRCNT=0,APCDLINE=0
  1.  I '$D(^AMHPSUIC("AC",DFN)) S APCDLESF(1,0)="No Suicide Forms currently on file for "_$P(^DPT(DFN,0),U),APCDLESF("IDX",1,1)="" S APCDRCNT=1 Q
  1.  S APCDSF=0 F  S APCDSF=$O(^AMHPSUIC("AC",DFN,APCDSF)) Q:APCDSF'=+APCDSF  D
  1.  .S APCDRCNT=APCDRCNT+1
  1.  .S X=APCDRCNT_") Local Case #: "_$P(^AMHPSUIC(APCDSF,0),U,2),$E(X,35)="Computer Generated Case #: "_$P(^AMHPSUIC(APCDSF,0),U)
  1.  .S APCDLINE=APCDLINE+1,APCDLESF(APCDLINE,0)=X,APCDLESF("IDX",APCDLINE,APCDRCNT)=APCDSF
  1.  .S X="   Date of Act: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.06),$E(X,35)="Provider: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.03)
  1.  .S APCDLINE=APCDLINE+1,APCDLESF(APCDLINE,0)=X,APCDLESF("IDX",APCDLINE,APCDRCNT)=APCDSF
  1.  .S X="   Self Destructive Act: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.13),APCDLINE=APCDLINE+1,APCDLESF(APCDLINE,0)=X,APCDLESF("IDX",APCDLINE,APCDRCNT)=APCDSF
  1.  .S Y="",Z=0 F  S Z=$O(^AMHPSUIC(APCDSF,11,Z)) Q:Z'=+Z  S Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$P(^AMHPSUIC(APCDSF,11,Z,0),U))_"  "
  1.  .S X="   Method: "_Y,APCDLINE=APCDLINE+1,APCDLESF(APCDLINE,0)=X,APCDLESF("IDX",APCDLINE,APCDRCNT)=APCDSF
  1.  Q
  1. EDIT ;EP - called from protocol
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." G EXIT
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." G EXIT
  1.  S APCDSF=0,(X,Y)=0 F  S X=$O(APCDLESF("IDX",X)) Q:X'=+X!(APCDSF)  I $O(APCDLESF("IDX",X,0))=R S Y=$O(APCDLESF("IDX",X,0)),APCDSF=APCDLESF("IDX",X,Y)
  1.  I '$D(^AMHPSUIC(APCDSF,0)) W !,"Not a valid SUICIDE RECORD." K APCDRDEL,R,APCDSF,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1.  S DA=APCDSF,DIE="^AMHPSUIC(",DR=".21////"_DT_";.22////"_DUZ D ^DIE
  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." G EXIT
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." G EXIT
  1.  S APCDSF=0,(X,Y)=0 F  S X=$O(APCDLESF("IDX",X)) Q:X'=+X!(APCDSF)  I $O(APCDLESF("IDX",X,0))=R S Y=$O(APCDLESF("IDX",X,0)),APCDSF=APCDLESF("IDX",X,Y)
  1.  I '$D(^AMHPSUIC(APCDSF,0)) W !,"Not a valid SUICIDE RECORD." K APCDRDEL,R,APCDSF,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1.  ;NEW DFN,APCDPAT
  1.  D EP^APCDLES1(APCDSF)
  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("APCDZ SUICIDE FORM DELETE",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." G EXIT
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." G EXIT
  1.  S APCDSF=0,(X,Y)=0 F  S X=$O(APCDLESF("IDX",X)) Q:X'=+X!(APCDSF)  I $O(APCDLESF("IDX",X,0))=R S Y=$O(APCDLESF("IDX",X,0)),APCDSF=APCDLESF("IDX",X,Y)
  1.  I '$D(^AMHPSUIC(APCDSF,0)) W !,"Not a valid SUICIDE RECORD." K APCDRDEL,R,APCDSF,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  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=APCDSF,DIK="^AMHPSUIC(" D ^DIK
  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,APCDPAT D VIEWR^XBLM("EN^APCHS",%)
  1.  D EN^XBVK("APCH") K AMCHDAYS,AMCHDOB,%
  1.  D EXIT
  1.  Q
  1. GETTYPE ;
  1.  S APCHSTYP=""
  1.  K DIC S DIC=9001015,DIC("A")="Select health summary type: ",DIC(0)="AEQM"
  1.  S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
  1.  I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
  1.  S:X="" X="ADULT REGULAR"
  1.  S DIC("B")=X
  1.  D ^DIC K DIC
  1.  Q:Y=-1
  1.  S APCHSTYP=+Y
  1.  Q
  1. ADDSF(APCDPAT) ;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 APCDDP=""
  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 APCDPROV=+Y
  1. GETDATE ;EP - GET DATE OF ENCOUNTER
  1.  W !!
  1.  S APCDDATE="",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 APCDDATE=Y
  1.  K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHPSUIC(",DLAYGO=9002011.65,DIADD=1,X=$$UPI(APCDPAT,APCDDATE),DIC("DR")=".06////"_APCDDATE_";.04////"_APCDPAT_";.03////"_APCDPROV_";.18////"_DT_";.19////"_DUZ_";.21////"_DT_";.22////"_DUZ
  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 APCDSF=+Y
  1.  D ADDDS
  1.  D EXIT
  1.  Q
  1. ADDDS ;screenman call
  1.  S AMHIISFE=1,AMHSF=APCDSF  ;NEED BH VARIABLES TO USE THAT SCREENMAN SCREEN
  1.  S DA=APCDSF,DDSFILE=9002011.65,DR="[APCD SUICIDE FORM UPDATE]" D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S APCDQUIT=1 K DIMSG D PAUSE,EXIT Q
  1.  D CHECK
  1.  Q
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. CHECK ; check record for completeness
  1.  S APCDC=0
  1.  F APCDF=.03:.01:.08 I $$VAL^XBDIQ1(9002011.65,APCDSF,APCDF)="" W !,$P(^DD(9002011.65,APCDF,0),U)," is a required data element." S APCDC=1
  1.  F APCDF=.11,.13:.01:.15,.25 I $$VAL^XBDIQ1(9002011.65,APCDSF,APCDF)="" W !,$P(^DD(9002011.65,APCDF,0),U)," is a required data element." S APCDC=1
  1.  ;I $P(^AMHPSUIC(APCDSF,0),U,16)="",$P(^AMHPSUIC(APCDSF,0),U,17)="" W !,"INTERVENTION is a required data element." S APCDC=1
  1.  S (Z,X,G)=0 F  S X=$O(^AMHPSUIC(APCDSF,11,X)) Q:X'=+X  D
  1.  .I $P($G(^AMHPSUIC(APCDSF,11,X,0)),U)]"" S G=1
  1.  .I $P(^AMHPSUIC(APCDSF,11,X,0),U,1)'=7 K ^AMHPSUIC(APCDSF,11,X,11)
  1.  .Q
  1.  I 'G W !!,"You must enter a METHOD." S APCDC=1
  1.  S G=$P(^AMHPSUIC(APCDSF,0),U,26)
  1.  I G="" W !!,"You must enter a value for SUBSTANCE Use.  None or Unknown are valid values." S APCDC=1
  1.  S (Z,G,X)=0 F  S X=$O(^AMHPSUIC(APCDSF,13,X)) Q:X'=+X  D
  1.  .I $P($G(^AMHPSUIC(APCDSF,13,X,0)),U)]"" S G=1
  1.  .Q
  1.  I 'G W !!,"You must enter a CONTRIBUTING FACTOR.  Unknown is a valid value." S APCDC=1
  1.  I APCDC W !!,"One or more required data elements are missing.",!! D  G:Y="E" ADDDS G:Y="L" EXIT W !,"Deleting form..." S DA=APCDSF,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=APCDLINE
  1.  D HDR
  1.  K X,Y,Z,I
  1.  D EN^XBVK("AMH")
  1.  Q
  1. EOJ ;
  1.  D EN^XBVK("APCD"),EN^XBVK("AMH"),EN^XBVK("APCH"),EN^XBVK("AMQQ")
  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. EXPND ; -- expand code
  1.  Q
  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) ;
  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.  ;