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