YSSR ;SLC/AFE,HIOFO/FT - SECLUSION/RESTRAINT - Lookup & Entry ;10/21/11 9:51am
;;5.01;MENTAL HEALTH;**82,60,107**;Dec 30, 1994;Build 23
;
;Reference to VADPT APIs supported by DBIA #10061
;Reference to XUSCLEAN APIs supported by DBIA #10052
;Reference to ^DPT( supported by DBIA #10035
;
ENLST ; Called from MENU option YSSR ENTRY
; Entry of basic S/R information
W @IOF,!?IOM-$L("SECLUSION/RESTRAINT INFORMATION")\2,"SECLUSION/RESTRAINT INFORMATION",! S MSG1="No patients listed in Seclusion/Restraint." D LKUP
ENTER ;
D ^YSLRP I YSDFN'>0 G END
I $D(^YS(615.2,"AC",YSDFN)) W !!,"Patient shown in Seclusion/Restraint at this time.",! D WAIT^YSUTL G END
W ! S DIC="^YS(615.2,",DIC(0)="L",X="""N""",DLAYGO=615.2 D ^DIC G:Y<1 END S FN=+Y
SQ ;
S %=0 F Q:$G(%) W !,"Was patient searched" S %=1 D
.D YN^DICN S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT) I '% W !!,"If patient was not searched, a reason should be given for the omission.",!
I YSTOUT!YSUOUT!(%=-1) D DELETE G END
N YSTO S YSTO=0 ;TimeOut check: 1=timed out
I %=1 D I YSTO D DELETE G END
. S DA=FN,DIE=DIC,DR=".08////Y"
. L +^YS(615.2,DA):DILOCKTM I '$T D ERRMSG^YSSITE S YSTO=1 Q
. D ^DIE L -^YS(615.2,DA)
I %=2 D I YSTO D DELETE G END
. S DA=FN,DIE=DIC,DR=".08////N;.09"
. L +^YS(615.2,DA):DILOCKTM I '$T D ERRMSG^YSSITE S YSTO=1 Q
. D ^DIE L -^YS(615.2,DA)
. S YSTOUT=$D(DTOUT)
. S:YSTOUT YSTO=1
D DXLKUP
W ! S DIE="^YS(615.2,",DA=FN,DR=".02////"_YSDFN_";.03//NOW;.04:.07;25:27;4///^S X=""`""_DUZ;5:6;7//^S X=YSDX;10;15:20;30"
L +^YS(615.2,DA):DILOCKTM
I '$T D ERRMSG^YSSITE D DELETE G END
K Y D ^DIE L -^YS(615.2,DA)
S YSTOUT=$D(DTOUT),YSUOUT=$O(Y(""))]""
I YSTOUT!YSUOUT!('$O(^YS(615.2,DA,5,0)))!('$O(^YS(615.2,DA,6,0)))!($G(^YS(615.2,DA,7))']"")!('$O(^(10,0)))!('+$G(^YS(615.2,DA,25))) W !!?13,"INSUFFICIENT INFORMATION" D DELETE G END
REVIEW ;
S %=0 F Q:$G(%) W !!,"Do you need to edit the above information" S %=1 D
.D YN^DICN S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT) I '% W !!,"After the information is filed, you may no longer edit it.",!,"You may alter the information now.",!
I YSTOUT!YSUOUT D DELETE G END
I %=1 D EDIT
FILE ;
S %=0 F Q:$G(%) W !!,"Save this information" S %=1 D
.D YN^DICN S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT) I '% W !!,"NO, will delete this information from the record.",!,"YES, will file it under the patient's name."
I %=1 W !!?5,"INFORMATION NOTED.",! Q
D DELETE
END ; Called by routines YSSR1, YSSR2
N YSDT,YSPDZ,YSTOUT,YSUOUT,XQT,YSDTM,YSLC,YSLCN,YSTM D KILL^XUSCLEAN
Q
EDIT ;
N DA,DIE,DR
S DIE="^YS(615.2,",DA=FN,DR=".03:3;5:25:27;30"
L +^YS(615.2,DA):DILOCKTM
I '$T D ERRMSG^YSSITE Q
D ^DIE L -^YS(615.2,DA)
Q
DELETE ; Called by routine YSSR2
N DA,DIK
S DIK="^YS(615.2,",DA=FN D ^DIK W !!?10,"< ENTRY FOR "_$P(YSNM,",",2)_" "_$P(YSNM,",")_" DELETED >",!
Q
PTNAME ; Called by routine YSSR1
; Patient look-up.
W ! D ^YSLRP I $G(X)["^" S YSQT=1 Q
I YSDFN<1 W !!,"Patient Name Required.",! S YSQT=1 Q
S YSN=$P(YSNM,",",2)_" "_$P(YSNM,",")
Q
LKUP ; Called as ENTRY action from MENU option YSSR SEC/RES
; Called by routine YSSR1
; Lists patients in currently in S/R. May pass YSQT.
S:'$D(MSG1) MSG1="No patients currently listed in seclusion/restraint." I '$O(^YS(615.2,"AC",0)) W !?IOM-$L(" ** "_MSG1_" ** ")\2," ** "_MSG1_" ** ",!! Q
W !!,"The following patient(s) are currently listed as being in Seclusion/Restraint: ",!
D HEADER S A=0 F S A=$O(^YS(615.2,"AC",A)) Q:'A S A1=0 F S A1=$O(^YS(615.2,"AC",A,A1)) Q:'A1 D PNAMES
I $D(YS02) W !!," * Written order required.",!
I $D(YS04) W:'$D(YS02) !! W " # Record incomplete, please contact IRM.",!
I '$D(C1) W !?5," ** ",MSG1," ** " K C1 I $D(OPT) S YSQT=1
S %DT="T",X="N" D ^%DT
K YS02,YS04
Q
PNAMES ; Called by routine YSSR1
K YS01,YS03 S DFN=A D DEM^VADPT,PID^VADPT S B=VADM(1),SSN=VA("BID") S C1=+1
S Y=$P($G(^YS(615.2,A1,0)),"^",3) D DD^%DT
D TTIME
S JRBY=$P($G(^YS(615.2,A1,25)),"^")
S JRBYN="" I JRBY S JRBYN=$P(^VA(200,JRBY,0),"^",1)
S Y=$P($G(^YS(615.2,A1,0)),"^",3) D DD^%DT
I $D(^YS(615.2,"AF",A)) S (YS01,YS02)="*"
I '$O(^YS(615.2,A1,5,0))!('$O(^YS(615.2,A1,6,0)))!($G(^YS(615.2,A1,7))']"")!('$O(^(10,0)))!('+$G(^YS(615.2,A1,25))) S (YS03,YS04)="#"
W !?0,$E(B,1,20),?22,SSN W:$D(YS01) ?28,YS01 I $D(YS03) W ?29,YS03
W ?31,Y,?52,$E(JRBYN,1,18) I $D(JRTT) W ?71,JRTT
K JRTT
K VADM,VA,DFN
Q
DXLKUP ; Checks ^YSD(627.8 DIAGNOSTIC RESULTS for most recent diagnosis.
N YSDXDAT
S YSDX="UNKNOWN" I '$D(^YSD(627.8,"AF",YSDFN)) Q
S K=0,K=$O(^YSD(627.8,"AF",YSDFN,K)),L="",L=$O(^YSD(627.8,"AF",YSDFN,K,L))
S M="",M=$O(^YSD(627.8,"AF",YSDFN,K,L,M)),YSDXDAT=""
I M]"" S YSDXDAT=$P($G(^YSD(627.8,M,0)),"^",3)
S M1=$P(L,";"),M2=$P(L,";",2) K K,L,M
I M2["YSD" D
. S N1="^"_M2_M1_","_0_")"
. S N2=$P(@N1,"^",1),YSDX=N2_" "_$E($G(^YSD(627.7,M1,"D")),1,60)
I M2["ICD" D Q
. S N1="^"_M2_M1_","_0_")"
. ;S YSDX=$P(@N1,"^",1)_" "_$E($P(@N1,"^",3),1,60)
. S YSDX=$$ICDDATA^ICDXCODE("DIAG",M1,YSDXDAT,"I")
. S YSDX=$P(YSDX,"^",2)_" "_$E($P(YSDX,"^",4),1,60)
I M2["DIC" S N1="^"_M2_M1_","_0_")",N2=$P(@N1,"^",2),N3="^"_M2_M1_","_3_")",N4=$P(@N3,"^",1),YSDX=N2_" "_$E(N4,1,60)
K M1,M2,N1,N2,N3,N4
Q
W !?31,"DATE & TIME",?72,"TOTAL",!
W ?0,"PATIENT",?23,"SSN",?31,"INITIATED",?52,"ORDERED BY",?72,"TIME",!
F I=1:1:IOM W "="
W !
Q
TTIME ;calculate total time
I $D(^YS(615.2,A1,0)),$P(^(0),"^",3)'="" S R1=$P(^YS(615.2,A1,0),"^",3)
I $D(^YS(615.2,A1,40)),$P(^(40),"^",3)'="" S R2=$P(^YS(615.2,A1,40),"^",3)
I '$D(^YS(615.2,A1,40)) D NOW^%DTC W ! S R2=%
I $D(R1),$D(R2) S Y=R2 D DD^%DT S JROSR=$P(Y,"@",2),Y=R1 D DD^%DT S JRISR=$P(Y,"@",2)
I $D(R1),$D(R2) D
. S X=R1,X1=R2
. ;next 2 lines are FileMan MINUTES function code
. S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1)
. D ^%DTC:X S X=X*1440+Y
. S R3=X,JRH=X\60,R4=JRH*60,JRMIN=R3-R4 S JRH=$S($L(JRH)=1:" "_JRH,$L(JRH)=2:" "_JRH,1:JRH)
. S JRH=" "_JRH,JRTT=JRH_":"_JRMIN
K R1,R2,R3,R4,JROSR,JRISR,JRH,JRMIN,Y,X,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSSR 6126 printed Oct 16, 2024@18:15:38 Page 2
YSSR ;SLC/AFE,HIOFO/FT - SECLUSION/RESTRAINT - Lookup & Entry ;10/21/11 9:51am
+1 ;;5.01;MENTAL HEALTH;**82,60,107**;Dec 30, 1994;Build 23
+2 ;
+3 ;Reference to VADPT APIs supported by DBIA #10061
+4 ;Reference to XUSCLEAN APIs supported by DBIA #10052
+5 ;Reference to ^DPT( supported by DBIA #10035
+6 ;
ENLST ; Called from MENU option YSSR ENTRY
+1 ; Entry of basic S/R information
+2 WRITE @IOF,!?IOM-$LENGTH("SECLUSION/RESTRAINT INFORMATION")\2,"SECLUSION/RESTRAINT INFORMATION",!
SET MSG1="No patients listed in Seclusion/Restraint."
DO LKUP
ENTER ;
+1 DO ^YSLRP
IF YSDFN'>0
GOTO END
+2 IF $DATA(^YS(615.2,"AC",YSDFN))
WRITE !!,"Patient shown in Seclusion/Restraint at this time.",!
DO WAIT^YSUTL
GOTO END
+3 WRITE !
SET DIC="^YS(615.2,"
SET DIC(0)="L"
SET X="""N"""
SET DLAYGO=615.2
DO ^DIC
if Y<1
GOTO END
SET FN=+Y
SQ ;
+1 SET %=0
FOR
if $GET(%)
QUIT
WRITE !,"Was patient searched"
SET %=1
Begin DoDot:1
+2 DO YN^DICN
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(DUOUT)
IF '%
WRITE !!,"If patient was not searched, a reason should be given for the omission.",!
End DoDot:1
+3 IF YSTOUT!YSUOUT!(%=-1)
DO DELETE
GOTO END
+4 ;TimeOut check: 1=timed out
NEW YSTO
SET YSTO=0
+5 IF %=1
Begin DoDot:1
+6 SET DA=FN
SET DIE=DIC
SET DR=".08////Y"
+7 LOCK +^YS(615.2,DA):DILOCKTM
IF '$TEST
DO ERRMSG^YSSITE
SET YSTO=1
QUIT
+8 DO ^DIE
LOCK -^YS(615.2,DA)
End DoDot:1
IF YSTO
DO DELETE
GOTO END
+9 IF %=2
Begin DoDot:1
+10 SET DA=FN
SET DIE=DIC
SET DR=".08////N;.09"
+11 LOCK +^YS(615.2,DA):DILOCKTM
IF '$TEST
DO ERRMSG^YSSITE
SET YSTO=1
QUIT
+12 DO ^DIE
LOCK -^YS(615.2,DA)
+13 SET YSTOUT=$DATA(DTOUT)
+14 if YSTOUT
SET YSTO=1
End DoDot:1
IF YSTO
DO DELETE
GOTO END
+15 DO DXLKUP
+16 WRITE !
SET DIE="^YS(615.2,"
SET DA=FN
SET DR=".02////"_YSDFN_";.03//NOW;.04:.07;25:27;4///^S X=""`""_DUZ;5:6;7//^S X=YSDX;10;15:20;30"
+17 LOCK +^YS(615.2,DA):DILOCKTM
+18 IF '$TEST
DO ERRMSG^YSSITE
DO DELETE
GOTO END
+19 KILL Y
DO ^DIE
LOCK -^YS(615.2,DA)
+20 SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$ORDER(Y(""))]""
+21 IF YSTOUT!YSUOUT!('$ORDER(^YS(615.2,DA,5,0)))!('$ORDER(^YS(615.2,DA,6,0)))!($GET(^YS(615.2,DA,7))']"")!('$ORDER(^(10,0)))!('+$GET(^YS(615.2,DA,25)))
WRITE !!?13,"INSUFFICIENT INFORMATION"
DO DELETE
GOTO END
REVIEW ;
+1 SET %=0
FOR
if $GET(%)
QUIT
WRITE !!,"Do you need to edit the above information"
SET %=1
Begin DoDot:1
+2 DO YN^DICN
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(DUOUT)
IF '%
WRITE !!,"After the information is filed, you may no longer edit it.",!,"You may alter the information now.",!
End DoDot:1
+3 IF YSTOUT!YSUOUT
DO DELETE
GOTO END
+4 IF %=1
DO EDIT
FILE ;
+1 SET %=0
FOR
if $GET(%)
QUIT
WRITE !!,"Save this information"
SET %=1
Begin DoDot:1
+2 DO YN^DICN
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(DUOUT)
IF '%
WRITE !!,"NO, will delete this information from the record.",!,"YES, will file it under the patient's name."
End DoDot:1
+3 IF %=1
WRITE !!?5,"INFORMATION NOTED.",!
QUIT
+4 DO DELETE
END ; Called by routines YSSR1, YSSR2
+1 NEW YSDT,YSPDZ,YSTOUT,YSUOUT,XQT,YSDTM,YSLC,YSLCN,YSTM
DO KILL^XUSCLEAN
+2 QUIT
EDIT ;
+1 NEW DA,DIE,DR
+2 SET DIE="^YS(615.2,"
SET DA=FN
SET DR=".03:3;5:25:27;30"
+3 LOCK +^YS(615.2,DA):DILOCKTM
+4 IF '$TEST
DO ERRMSG^YSSITE
QUIT
+5 DO ^DIE
LOCK -^YS(615.2,DA)
+6 QUIT
DELETE ; Called by routine YSSR2
+1 NEW DA,DIK
+2 SET DIK="^YS(615.2,"
SET DA=FN
DO ^DIK
WRITE !!?10,"< ENTRY FOR "_$PIECE(YSNM,",",2)_" "_$PIECE(YSNM,",")_" DELETED >",!
+3 QUIT
PTNAME ; Called by routine YSSR1
+1 ; Patient look-up.
+2 WRITE !
DO ^YSLRP
IF $GET(X)["^"
SET YSQT=1
QUIT
+3 IF YSDFN<1
WRITE !!,"Patient Name Required.",!
SET YSQT=1
QUIT
+4 SET YSN=$PIECE(YSNM,",",2)_" "_$PIECE(YSNM,",")
+5 QUIT
LKUP ; Called as ENTRY action from MENU option YSSR SEC/RES
+1 ; Called by routine YSSR1
+2 ; Lists patients in currently in S/R. May pass YSQT.
+3 if '$DATA(MSG1)
SET MSG1="No patients currently listed in seclusion/restraint."
IF '$ORDER(^YS(615.2,"AC",0))
WRITE !?IOM-$LENGTH(" ** "_MSG1_" ** ")\2," ** "_MSG1_" ** ",!!
QUIT
+4 WRITE !!,"The following patient(s) are currently listed as being in Seclusion/Restraint: ",!
+5 DO HEADER
SET A=0
FOR
SET A=$ORDER(^YS(615.2,"AC",A))
if 'A
QUIT
SET A1=0
FOR
SET A1=$ORDER(^YS(615.2,"AC",A,A1))
if 'A1
QUIT
DO PNAMES
+6 IF $DATA(YS02)
WRITE !!," * Written order required.",!
+7 IF $DATA(YS04)
if '$DATA(YS02)
WRITE !!
WRITE " # Record incomplete, please contact IRM.",!
+8 IF '$DATA(C1)
WRITE !?5," ** ",MSG1," ** "
KILL C1
IF $DATA(OPT)
SET YSQT=1
+9 SET %DT="T"
SET X="N"
DO ^%DT
+10 KILL YS02,YS04
+11 QUIT
PNAMES ; Called by routine YSSR1
+1 KILL YS01,YS03
SET DFN=A
DO DEM^VADPT
DO PID^VADPT
SET B=VADM(1)
SET SSN=VA("BID")
SET C1=+1
+2 SET Y=$PIECE($GET(^YS(615.2,A1,0)),"^",3)
DO DD^%DT
+3 DO TTIME
+4 SET JRBY=$PIECE($GET(^YS(615.2,A1,25)),"^")
+5 SET JRBYN=""
IF JRBY
SET JRBYN=$PIECE(^VA(200,JRBY,0),"^",1)
+6 SET Y=$PIECE($GET(^YS(615.2,A1,0)),"^",3)
DO DD^%DT
+7 IF $DATA(^YS(615.2,"AF",A))
SET (YS01,YS02)="*"
+8 IF '$ORDER(^YS(615.2,A1,5,0))!('$ORDER(^YS(615.2,A1,6,0)))!($GET(^YS(615.2,A1,7))']"")!('$ORDER(^(10,0)))!('+$GET(^YS(615.2,A1,25)))
SET (YS03,YS04)="#"
+9 WRITE !?0,$EXTRACT(B,1,20),?22,SSN
if $DATA(YS01)
WRITE ?28,YS01
IF $DATA(YS03)
WRITE ?29,YS03
+10 WRITE ?31,Y,?52,$EXTRACT(JRBYN,1,18)
IF $DATA(JRTT)
WRITE ?71,JRTT
+11 KILL JRTT
+12 KILL VADM,VA,DFN
+13 QUIT
DXLKUP ; Checks ^YSD(627.8 DIAGNOSTIC RESULTS for most recent diagnosis.
+1 NEW YSDXDAT
+2 SET YSDX="UNKNOWN"
IF '$DATA(^YSD(627.8,"AF",YSDFN))
QUIT
+3 SET K=0
SET K=$ORDER(^YSD(627.8,"AF",YSDFN,K))
SET L=""
SET L=$ORDER(^YSD(627.8,"AF",YSDFN,K,L))
+4 SET M=""
SET M=$ORDER(^YSD(627.8,"AF",YSDFN,K,L,M))
SET YSDXDAT=""
+5 IF M]""
SET YSDXDAT=$PIECE($GET(^YSD(627.8,M,0)),"^",3)
+6 SET M1=$PIECE(L,";")
SET M2=$PIECE(L,";",2)
KILL K,L,M
+7 IF M2["YSD"
Begin DoDot:1
+8 SET N1="^"_M2_M1_","_0_")"
+9 SET N2=$PIECE(@N1,"^",1)
SET YSDX=N2_" "_$EXTRACT($GET(^YSD(627.7,M1,"D")),1,60)
End DoDot:1
+10 IF M2["ICD"
Begin DoDot:1
+11 SET N1="^"_M2_M1_","_0_")"
+12 ;S YSDX=$P(@N1,"^",1)_" "_$E($P(@N1,"^",3),1,60)
+13 SET YSDX=$$ICDDATA^ICDXCODE("DIAG",M1,YSDXDAT,"I")
+14 SET YSDX=$PIECE(YSDX,"^",2)_" "_$EXTRACT($PIECE(YSDX,"^",4),1,60)
End DoDot:1
QUIT
+15 IF M2["DIC"
SET N1="^"_M2_M1_","_0_")"
SET N2=$PIECE(@N1,"^",2)
SET N3="^"_M2_M1_","_3_")"
SET N4=$PIECE(@N3,"^",1)
SET YSDX=N2_" "_$EXTRACT(N4,1,60)
+16 KILL M1,M2,N1,N2,N3,N4
+17 QUIT
+1 WRITE !?31,"DATE & TIME",?72,"TOTAL",!
+2 WRITE ?0,"PATIENT",?23,"SSN",?31,"INITIATED",?52,"ORDERED BY",?72,"TIME",!
+3 FOR I=1:1:IOM
WRITE "="
+4 WRITE !
+5 QUIT
TTIME ;calculate total time
+1 IF $DATA(^YS(615.2,A1,0))
IF $PIECE(^(0),"^",3)'=""
SET R1=$PIECE(^YS(615.2,A1,0),"^",3)
+2 IF $DATA(^YS(615.2,A1,40))
IF $PIECE(^(40),"^",3)'=""
SET R2=$PIECE(^YS(615.2,A1,40),"^",3)
+3 IF '$DATA(^YS(615.2,A1,40))
DO NOW^%DTC
WRITE !
SET R2=%
+4 IF $DATA(R1)
IF $DATA(R2)
SET Y=R2
DO DD^%DT
SET JROSR=$PIECE(Y,"@",2)
SET Y=R1
DO DD^%DT
SET JRISR=$PIECE(Y,"@",2)
+5 IF $DATA(R1)
IF $DATA(R2)
Begin DoDot:1
+6 SET X=R1
SET X1=R2
+7 ;next 2 lines are FileMan MINUTES function code
+8 SET Y=$EXTRACT(X1_"000",9,10)-$EXTRACT(X_"000",9,10)*60+$EXTRACT(X1_"00000",11,12)-$EXTRACT(X_"00000",11,12)
SET X2=X
SET X=$PIECE(X,".",1)'=$PIECE(X1,".",1)
+9 if X
DO ^%DTC
SET X=X*1440+Y
+10 SET R3=X
SET JRH=X\60
SET R4=JRH*60
SET JRMIN=R3-R4
SET JRH=$SELECT($LENGTH(JRH)=1:" "_JRH,$LENGTH(JRH)=2:" "_JRH,1:JRH)
+11 SET JRH=" "_JRH
SET JRTT=JRH_":"_JRMIN
End DoDot:1
+12 KILL R1,R2,R3,R4,JROSR,JRISR,JRH,JRMIN,Y,X,%
+13 QUIT
