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

APCDESF1.m

Go to the documentation of this file. 
  1. APCDESF1 ; IHS/CMI/LAB - HS IN DATA ENTRY ;
  1.  ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
  1.  ;
  1. EP ;EP - called from input template
  1.  I $G(AUPNPAT)="" W !!,$C(7),$C(7),"Sorry I don't know the patient.",! Q
  1. PROV ;
  1.  D ^XBFMK
  1.  S APCDSFDP=""
  1.  W !! S DIC("A")="Enter the Provider who completed 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 APCDSFPR=+Y
  1. GETDATE ;EP - GET DATE OF ENCOUNTER
  1.  W !!
  1.  S APCDSFDT="",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 APCDSFDT=Y
  1.  S APCDSFQT=""
  1.  S APCDSFI=$$HAVEONE(AUPNPAT,APCDSFDT)
  1.  I APCDSFI D  G:'APCDSFQT EDIT I APCDSFQT D EXIT Q
  1.  .W !!,"There is already a suicide form on file for ",$P(^DPT(AUPNPAT,0),U)," on ",!,$$FMTE^XLFDT(APCDSFDT),"."
  1.  .W !,"If this is an addition of a new form, Please notify ",$P(^VA(200,APCDSFPR,0),U)
  1.  .W !,"that a form has already been entered by ",$$VAL^XBDIQ1(9002011.65,APCDSFI,.03),".",!!
  1.  .K DIR S DIR(0)="Y",DIR("A")="Do you want to continue and EDIT this form",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCDSFQT=1 Q
  1.  .I 'Y S APCDSFQT=1 Q
  1.  K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHPSUIC(",DLAYGO=9002011.65,DIADD=1,X=$$UPI(AUPNPAT,APCDSFDT),DIC("DR")=".06////"_APCDSFDT_";.04////"_AUPNPAT_";.03////"_APCDSFPR_";.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 EXIT Q
  1.  S APCDSFI=+Y
  1. EDIT ;
  1.  W !!,"Please note:  If while entering the data from the suicide form you make"
  1.  W !,"a mistake, you can edit the field by '^' jumping to that field."
  1.  W !,"For example:  to go back to edit EMPLOYMENT STATUS after you have passed"
  1.  W !,"              that field, type ^EMPLOY and you will be taken back to that"
  1.  W !,"              field to edit it.",!
  1.  S DA=APCDSFI,DIE="^AMHPSUIC(",DR="[APCD SF EDIT]" D ^DIE
  1.  ;display form and ask if okay to save otherwise edit again
  1.  D DISPLAY(APCDSFI)
  1.  ;OKAY?
  1.  K DIR S DIR(0)="S^Y:Yes, save it;N:No, I wish to edit the data",DIR("A")="Are you finished entering this suicide form",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  I Y'="Y" G EDIT
  1.  D EXIT
  1.  Q
  1. EXIT ;
  1.  D EN^XBVK("APCD")
  1.  D ^XBFMK
  1.  Q
  1.  ;
  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.  ;
  1. HAVEONE(P,D) ;is there a suicide form on file for this patient, this date, pass back ien
  1.  NEW Y
  1.  S Y=$$UPI(P,D)
  1.  I $D(^AMHPSUIC("B",Y)) Q $O(^AMHPSUIC("B",Y,0))
  1.  Q ""
  1.  ;
  1. DISPLAY(APCDSF) ;
  1.  W !!,"I will now display the form back to you so you can check"
  1.  W !,"the accuracy of the entry of the data.",!
  1.  K DIR S DIR(0)="E",DIR("A")="Press Enter to Continue" KILL DA D ^DIR KILL DIR
  1.  S XBRP="VIEWR^XBLM(""PRINT^APCDESF1"")"
  1.  S XBRC="",XBRX="EXIT1^APCDESF1",XBIOP=0 D ^XBDBQUE
  1.  Q
  1. EXIT1 ;
  1.  D ^XBFMK
  1.  Q
  1. EP2(APCDSF) ;
  1.  S DFN=$P(^AMHPSUIC(APCDSF,0),U,4)
  1.  K ^TMP("APCDS",$J,"DCS")
  1.  S ^TMP("APCDS",$J,"DCS",0)=0
  1.  D SETARRAY
  1.  Q
  1. SETARRAY ;set up array containing dm care summary
  1.  S X="Suicide Reporting Form                  Date Printed:  "_$$FMTE^XLFDT(DT) D S(X)
  1.  S X="Case #: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.01) D S(X)
  1.  S X="Local Case #: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.02) D S(X)
  1.  S X="COMMUNITY WHERE ACT OCCURRED: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.07) D S(X)
  1.  S X="DATE OF ACT: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.06) D S(X)
  1.  S X="PROVIDER FILLING OUT FORM: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.03) D S(X)
  1.  S X="EMPLOYMENT STATUS: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.05) D S(X)
  1.  S X="RELATIONSHIP STATUS: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.08) D S(X)
  1.  S X="EDUCATION: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.11) D S(X)
  1.  I $P(^AMHPSUIC(APCDSF,0),U,12)]"" S X=" IF LESS THAN 12 YEARS, HIGHEST GRADE: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.12) D S(X)
  1.  S X="SELF DESTRUCTIVE ACT: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.13) D S(X)
  1.  S X="LOCATION OF ACT: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.15) D S(X)
  1.  I $P($G(^AMHPSUIC(APCDSF,14)),U)]"" S X="  LOCATION OF ACT, IF OTHER: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,1401) D S(X)
  1.  S X="PREVIOUS ATTEMPTS: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.14) D S(X)
  1. MET ;
  1.  K APCDOD,APCDO 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))_"  " D
  1.  .I $P(^AMHPSUIC(APCDSF,11,Z,0),U,2)]"" S APCDO(Z)=$P(^AMHPSUIC(APCDSF,11,Z,0),U,2)
  1.  .S A=0 F  S A=$O(^AMHPSUIC(APCDSF,11,Z,11,A)) Q:A'=+A  D
  1.  ..S APCDOD(Z,A)=$P(^AMHTSDRG($P(^AMHPSUIC(APCDSF,11,Z,11,A,0),U),0),U)_"   "_$P(^AMHPSUIC(APCDSF,11,Z,11,A,0),U,2)
  1.  ..Q
  1.  S X="METHOD: ",$E(X,40)=Y D S(X)
  1.  I $D(APCDO) S X="  OTHER METHOD: " D
  1.  .S A=0 F  S A=$O(APCDO(A)) Q:A'=+A  S X=X_APCDO(A)_"  "
  1.  .D S(X)
  1.  I $D(APCDOD) D
  1.  .S X="    DRUGS W/OVERDOSE: "
  1.  .S Y=0 F  S Y=$O(APCDOD(Y)) Q:Y'=+Y  D
  1.  ..S A=0 F  S A=$O(APCDOD(Y,A)) Q:A'=+A  S X=X_APCDOD(Y,A)_"  "
  1.  .D S(X)
  1. DRUG ;
  1.  S X="SUBSTANCE USE INVOLVED: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.26) D S(X)
  1.  I $P(^AMHPSUIC(APCDSF,0),U,26)=2 D
  1.  .S X="    ALCOHOL OR DRUGS INVOLVED: "
  1.  .S Y=0 F  S Y=$O(^AMHPSUIC(APCDSF,15,Y)) Q:Y'=+Y  D
  1.  ..S A=$P(^AMHPSUIC(APCDSF,15,Y,0),U) I A S $E(X,40)=$P($G(^AMHTSSU(A,0)),U) D S(X)
  1.  ..S X=$P(^AMHPSUIC(APCDSF,15,Y,0),U,2) I X]"" S X="     OTHER DRUG: "_X D S(X)
  1.  S X="CONTRIBUTING FACTORS: " D S(X)
  1.  S Z=0 F  S Z=$O(^AMHPSUIC(APCDSF,13,Z)) Q:Z'=+Z  S X="",$E(X,20)=$P(^AMHTSCF($P(^AMHPSUIC(APCDSF,13,Z,0),U),0),U) S:$P(^AMHPSUIC(APCDSF,13,Z,0),U,2)]"" X=X_" - "_$P(^AMHPSUIC(APCDSF,13,Z,0),U,2) D S(X)
  1.  I $$VAL^XBDIQ1(9002011.65,APCDSF,.24)]"" S X="LETHALITY: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.24) D S(X)
  1.  S X="DISPOSITION: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,.25) D S(X)
  1.  I $P($G(^AMHPSUIC(APCDSF,14)),U,2)]"" S X="  DISPOSITION, IF OTHER: ",$E(X,40)=$$VAL^XBDIQ1(9002011.65,APCDSF,1402) D S(X)
  1.  S X="  Narrative: " D S(X)
  1. WP ;
  1.  K ^UTILITY($J,"W")
  1.  S APCDX=0
  1.  S DIWL=5,DIWR=75 F  S APCDX=$O(^AMHPSUIC(APCDSF,41,APCDX)) Q:APCDX'=+APCDX  D
  1.  .S X=^AMHPSUIC(APCDSF,41,APCDX,0) D ^DIWP
  1.  .Q
  1. WPS ;
  1.  S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  S X="",$E(X,5)=^UTILITY($J,"W",DIWL,Z,0) D S(X)
  1.  K DIWL,DIWR,DIWF,Z
  1.  K ^UTILITY($J,"W"),APCDX
  1.  Q
  1. S(Y,F,C,T) ;set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  ;blank lines
  1.  F F=1:1:F S X="" D S1
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  D S1
  1.  Q
  1. S1 ;
  1.  S %=$P(^TMP("APCDS",$J,"DCS",0),U)+1,$P(^TMP("APCDS",$J,"DCS",0),U)=%
  1.  S ^TMP("APCDS",$J,"DCS",%)=X
  1.  Q
  1. PRINT ;EP
  1.  K ^TMP("APCDS",$J)
  1.  D EP2(APCDSFI) ;gather up data
  1. W ;write out array
  1.  ;W:$D(IOF) @IOF
  1.  K APCDQUIT
  1.  ;W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********"
  1.  S APCDX=0 F  S APCDX=$O(^TMP("APCDS",$J,"DCS",APCDX)) Q:APCDX'=+APCDX!($D(APCDQUIT))  D
  1.  .;I $Y>(IOSL-3) D HEADER Q:$D(APCDQUIT)
  1.  .W !,^TMP("APCDS",$J,"DCS",APCDX)
  1.  .Q
  1.  I $D(APCDQUIT) S APCDSQIT=1
  1.  D EOJ
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K ^TMP("APCDS",$J)
  1.  K APCDX,APCDQUIT,APCDY,APCDSBEG,APCDSTOB,APCDSUPI,APCDSED,APCDTOBN,APCDTOB,APCDOD,APCDO,X,Y,Z,APCDOPT,APCDSF,APCDSQIT,APCDOD
  1.  K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
  1.  Q
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCDQUIT="" Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF
  1.  W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!!
  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. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. EPDE ;EP
  1.  D EN^XBNEW("EP^APCDESF1","AUPN*;VALM*") K Y
  1.  Q