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

APCLPSU3.m

Go to the documentation of this file. 
  1. APCLPSU3 ; IHS/CMI/LAB - Suicide Form data element tally ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1.  ;
  1. START ;
  1.  W:$D(IOF) @IOF
  1.  D EOJ
  1.  W:$D(IOF) @IOF
  1.  W !!,"Extract Suicide Form Data Elements in Delimited format"
  1.  W !!,"This report will extract all data elements on the Suicide Form in a ",!,"delimited form for a date range specified by the user.",!!
  1. GETDATES ;
  1. BD ;
  1.  S DIR(0)="D^::EP",DIR("A")="Enter Beginning Date of Suicide Act",DIR("?")="Enter the beginning date of suicide act for the search." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  G:$D(DIRUT) EOJ
  1.  S APCLBD=Y
  1. ED ;
  1.  S DIR(0)="DA^::EP",DIR("A")="Enter Ending Date of Suicide Act:  " D ^DIR K DIR,DA S:$D(DUOUT) DIRUT=1
  1.  G:$D(DIRUT) EOJ
  1.  I Y<APCLBD W !,"Ending date must be greater than or equal to beginning date!" G ED
  1.  S APCLED=Y
  1.  S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
  1. ZIS ;
  1. DEMO ;
  1.  D DEMOCHK^APCLUTL(.APCLDEMO)
  1.  I APCLDEMO=-1 G GETDATES
  1.  S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
  1.  I $D(DIRUT) G EOJ
  1.  I $G(Y)="B" D BROWSE,EOJ Q
  1.  W !! S XBRP="PRINT^APCLPSU3",XBRC="PROC^APCLPSU3",XBNS="APCL",XBRX="EOJ^APCLPSU3"
  1.  D ^XBDBQUE
  1.  D EOJ
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^APCLPSU3"")"
  1.  S XBNS="APCL",XBRC="PROC^APCLPSU3",XBRX="EOJ^APCLPSU3",XBIOP=0 D ^XBDBQUE
  1.  Q
  1.  ;
  1. PAUSE ; 
  1.  S DIR(0)="E",DIR("A")="Press return to continue or '^' to quit" D ^DIR K DIR,DA
  1.  S:$D(DIRUT) APCLQUIT=1
  1.  W:$D(IOF) @IOF
  1.  Q
  1. EOJ ;
  1.  D EN^XBVK("APCL")
  1.  K L,M,S,T,X,X1,X2,Y,Z,B,A
  1.  D KILL^AUPNPAT
  1.  D ^XBFMK
  1.  Q
  1. PROC ;EP
  1.  S APCLJ=$J,APCLH=$H
  1.  K ^XTMP("APCLPSU3",APCLJ,APCLH)
  1.  D XTMP("APCLPSU3","APCL - SUICIDE")
  1. V ; Run by visit date
  1.  F  S APCLSD=$O(^AMHPSUIC("AD",APCLSD)) Q:APCLSD=""!((APCLSD\1)>APCLED)  D V1
  1.  Q
  1.  ;
  1. V1 ;
  1.  S APCLVDFN="" F  S APCLVDFN=$O(^AMHPSUIC("AD",APCLSD,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  D
  1.  .Q:$$DEMO^APCLUTL($P(^AMHPSUIC(APCLVDFN,0),U,4))
  1.  .S APCLREC="" F APCLX=1:1:21 S APCLT=$T(@APCLX) D
  1.  ..S APCLP=$P(APCLT,";;",1),APCLV=$P(APCLT,";;",3)
  1.  ..X APCLV
  1.  ..S $P(APCLREC,U,APCLP)=X
  1.  ..Q
  1.  .;rest of multiples
  1.  .S APCLC=21,APCLX=0 F  S APCLX=$O(^AMHPSUIC(APCLVDFN,11,APCLX)) Q:APCLX'=+APCLX!(APCLC>24)  D
  1.  ..S APCLC=APCLC+1
  1.  ..S Y=$P(^AMHPSUIC(APCLVDFN,11,APCLX,0),U),$P(APCLREC,U,APCLC)=$$EXTSET^XBFUNC(9002011.6511,.01,Y)
  1.  .S APCLC=25,APCLX=0 S APCLX=$P(^AMHPSUIC(APCLVDFN,0),U,26)  D
  1.  ..S APCLC=APCLC+1
  1.  ..S Y=$P(^AMHPSUIC(APCLVDFN,0),U,26),$P(APCLREC,U,APCLC)=$$EXTSET^XBFUNC(9002011.65,.26,Y)
  1.  .S APCLC=29,APCLX=0 F  S APCLX=$O(^AMHPSUIC(APCLVDFN,13,APCLX)) Q:APCLX'=+APCLX!(APCLC>32)  D
  1.  ..S APCLC=APCLC+1
  1.  ..S Y=$P(^AMHPSUIC(APCLVDFN,13,APCLX,0),U),$P(APCLREC,U,APCLC)=$P(^AMHTSCF(Y,0),U,1)
  1.  .S ^XTMP("APCLPSU3",APCLJ,APCLH,"RECS",APCLVDFN)=APCLREC
  1.  Q
  1. PRINT ;EP called from xbdbque
  1.  W:$D(IOF) @IOF
  1.  W !,$$LOC,"^^^",$$FMTE^XLFDT(DT)
  1.  S X="***** AGGREGATED SUICIDE DATA *****" W !,X,!
  1.  W "Act Occurred","^",$$FMTE^XLFDT(APCLBD),"^",$$FMTE^XLFDT(APCLED),!
  1.  F APCLX=1:1:21 S APCLT=$T(@APCLX),APCLT=$P(APCLT,";;",2) S $P(X,U,APCLX)=APCLT
  1.  F APCLX=22:1:25 S $P(X,U,APCLX)="Method "_(APCLX-21)
  1.  F APCLX=26:1:29 S $P(X,U,APCLX)="Substance Involved "
  1.  F APCLX=30:1:33 S $P(X,U,APCLX)="Contributing Factor "_(APCLX-29)
  1.  W !!,X
  1.  S APCLVDFN="" F  S APCLVDFN=$O(^XTMP("APCLPSU3",APCLJ,APCLH,"RECS",APCLVDFN)) Q:APCLVDFN=""  D
  1.  .W !,^XTMP("APCLPSU3",APCLJ,APCLH,"RECS",APCLVDFN)
  1. DONE ;
  1.  I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  PRESS RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  K ^XTMP("APCLPSU3",APCLJ,APCLH)
  1.  Q
  1. LBLK(V,L) ;left blank fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
  1.  Q V
  1. RBLK(V,L) ;EP right blank fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
  1.  Q V
  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. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  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. XTMP(N,D) ;EP - set xtmp 0 node
  1.  Q:$G(N)=""
  1.  S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
  1.  Q
  1.  ;
  1. LABEL ;
  1. 1 ;;Unique Case ID;;S X=$P(^AMHPSUIC(APCLVDFN,0),U)
  1. 2 ;;Local Case #;;S X=$P(^AMHPSUIC(APCLVDFN,0),U,2)
  1. 3 ;;Event logged by;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.031)
  1. 4 ;;Discipline of Prov;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.032)
  1. 5 ;;Unique ID of Patient;;S X=$P(^AMHPSUIC(APCLVDFN,0),U,4),X=$$UID^AGTXID(X)
  1. 6 ;;Sex of Patient;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.041)
  1. 7 ;;Age of Patient on date of act;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.043)
  1. 8 ;;Tribe of Enrollment;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.044)
  1. 9 ;;Community of Residence;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.045)
  1. 10 ;;Employment Status;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.05)
  1. 11 ;;Date of Act;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.06)
  1. 12 ;;Community where act occurred;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.07)
  1. 13 ;;Relationship Status;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.08)
  1. 14 ;;Relationship if Other;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.09)
  1. 15 ;;Education Level;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.11)
  1. 16 ;;If less than 12;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.12)
  1. 17 ;;Self Destructive Act;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.13)
  1. 18 ;;Previous Attempts;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.14)
  1. 19 ;;Location of Act;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.15)
  1. 20 ;;Lethality;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.24)
  1. 21 ;;Disposition;;S X=$$VAL^XBDIQ1(9002011.65,APCLVDFN,.25)