DIWE ;SFISC/GFT,XAK-START OF WP ;2013-07-10 2:39 PM
;;22.2;VA FileMan;**24**;Jan 05, 2016;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
EN K DTOUT,DUOUT,DIRUT ;G Q:'$D(@(DIC_"0)")) D A
I $E($G(DIC))'="^" G Q ;make sure DIC is a Global -p24
L @("+"_DIC_"0):1") E W !,$$EZBLD^DIALOG(110) G Q ;**CCO/NI--'THE RECORD IS LOCKED'
D A
OPT K:DIWE'=2 DDWC,DDWRW I DIWE>1 S DIWE(2)=1 G OPT^DIWE12
GO S:$D(DTIME)[0 DTIME=300
S @(DIC_"0)")=DWLC G ^DIWE1:DWLC D ^DIWE2 S (DWL,DWLC)=DWI G GO:DWL,X
;
DIEN ;FROM ^DIE
I '$D(DIA) N DIA S DIA=DIE,DIA("P")=DP
S DH=$P(Y,U),DV=DG,DWPK="FM",(DIC,Y)=DIE_DA_",DV",DWO="ABCDE IJLMPRSTU"_$E("Y",DUZ(0)="@") S:'$D(DIWESUB) DIWESUB=DH D A G W:'$D(DE(1,0))
S X=DE(1,0),DWI=X?1"/".E,@(DIC_"0)")=DWLC S:DWI X=$E(X,2,999) I X?1"+".E S X=$E(X,2,999)
E G W:'DWI&DWLC K:DWLC @(Y_")") S DWLC=0 Q:X="@"
I X?1"^".E S DIW=DIC,DICMX="S DWLC=DWLC+1,"_DIC_",DWLC,0)=X",DIWL=DWLC X $E(X,2,999) S DIC=DIW S:DIWL-DWLC X="" K DICMX,DIWL,DIW
S:X]"" DWLC=DWLC+1,@(DIC_"DWLC,0)=X") G X:DWI
W W !?DL+DL-2
S Z=+$P($G(DC),U,2),Z=$S(Z:$P($G(^DD(Z,.01,0)),U,2),1:"") I Z["I",DWLC W !,$$EZBLD^DIALOG(3090,DH),! S I=DWLC,J=1 D LL^DIWE1 G Q ;UNEDITABLE W-P
W DH_":" N DIET I Z["a",$G(DV)]"",$G(DIC)["DV" M DIET=@$$CREF^DILF(DIC)
G OPT
;
A S:$E(DIC,$L(DIC))'="," DIC=DIC_"," S:'$D(DWO) DWO="ABCDE IJLMPRSTU"_$E(" Y",$S($G(DUZ(0))="@":2,1:1))
S:$G(DWDISABL)]"" DWO=$TR(DWO,DWDISABL,$J("",$L(DWDISABL)))
I $D(^VA(200,0))#2,^(0)'["NEW PERSON",'$D(DDS) D
. W !!?2,$C(7)_"WARNING: You appear to have a file #200 stored at ^VA(200),"
. W !?11,"but it is not named 'NEW PERSON.' I will assume your"
. W !?11,"preferred editor is the Line Editor.",!
K DWL,DIWE S U="^",DIWPT=$S('$D(^VA(200,0)):"",^(0)'["NEW PERSON":"",'$D(^VA(200,+DUZ,1)):"",1:$P(^(1),U,4))
S DIWE=$S('$D(^VA(200,0)):0,^(0)'["NEW PERSON":0,'$D(^VA(200,+DUZ,1)):0,1:+$P(^(1),U,5)),DIWE=$S($D(^DIST(1.2,DIWE,0)):DIWE,1:0) S:'DIWE DIWE=$S($D(DDS)#2:2,1:1)
S @("J=$O("_DIC_"0))>0") I '$D(^(0))!'J S ^(0)=""
S DWHD=^(0)_U,DWLC=+$P(DWHD,U,3),DWLW=$S($D(DWLW):DWLW,1:245) I J D REPACK:DWLC-$P(DWHD,U,4)!'DWLC!'$D(^(DWLC))
S DWPK=$S($D(DWPK):DWPK,1:2),DWLR=245,DWLC=$S('DWLC:+DWHD,1:DWLC)
Q
;
REPACK K ^UTILITY($J,"W") S J=0 F I=0:0 S @("J=$O("_DIC_"J))") Q:J'>0 S:$D(^(J,0)) I=I+1,^UTILITY($J,"W",I)=^(0) W:'$D(ZTQUEUED) "."
K @($E(DIC,1,$L(DIC)-1)_")") F J=1:1:I S @(DIC_"J,0)=^UTILITY($J,""W"",J)") W:'$D(ZTQUEUED) "."
K ^UTILITY($J,"W") S DWLC=I,$P(@(DIC_"0)"),U,3,4)=I_U_I Q
;
X Q:$D(DIWE(1)) I $D(DT)[0 D NOW^%DTC S DT=X K %I
I $D(DIET)>9,$G(DP),$G(DIFLD(1)),'$G(DIDNEDIT) D WP^DIET(DP,DIFLD(1),$$IENS^DILF(.DA),"DIET") ;AUDIT Word -Processing, but not if we didn't touch it
I @("$O("_DIC_"0))'>0") K @($E(DIC,1,$L(DIC)-1)_")") G Q
I $D(@(DIC_"0)"))#2 G Q:$P(^(0),U,5)?7N.1P.6N ;Has already been updated.
S ^(0)=$P(DWHD,U,1,2)_U_DWLC_U_DWLC_U_DT_U_$P(DWHD,U,6,9)
D:$D(DDS) INIT^DDGLIB0()
Q L @("-"_DIC_"0)") K DW2,DW3,DIWPT,DWO,DWLR,DWHD,DWL,DWPK,DWI,DWJ,DWLC
K Y,Z,DWAFT,DWLW,DIW,D,DIWE,DIWETXT,DIWESUB,DDWLMAR,DDWRMAR,DDWFLAGS,DWDISABL,DDWAUTO,DDWTAB,DC,DIWEX1 ;**CCO/NI CLEAN UP VARIABLES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIWE 3363 printed Dec 13, 2024@02:54:51 Page 2
DIWE ;SFISC/GFT,XAK-START OF WP ;2013-07-10 2:39 PM
+1 ;;22.2;VA FileMan;**24**;Jan 05, 2016;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
EN ;G Q:'$D(@(DIC_"0)")) D A
KILL DTOUT,DUOUT,DIRUT
+1 ;make sure DIC is a Global -p24
IF $EXTRACT($GET(DIC))'="^"
GOTO Q
+2 ;**CCO/NI--'THE RECORD IS LOCKED'
LOCK @("+"_DIC_"0):1")
IF '$TEST
WRITE !,$$EZBLD^DIALOG(110)
GOTO Q
+3 DO A
OPT if DIWE'=2
KILL DDWC,DDWRW
IF DIWE>1
SET DIWE(2)=1
GOTO OPT^DIWE12
GO if $DATA(DTIME)[0
SET DTIME=300
+1 SET @(DIC_"0)")=DWLC
if DWLC
GOTO ^DIWE1
DO ^DIWE2
SET (DWL,DWLC)=DWI
if DWL
GOTO GO
GOTO X
+2 ;
DIEN ;FROM ^DIE
+1 IF '$DATA(DIA)
NEW DIA
SET DIA=DIE
SET DIA("P")=DP
+2 SET DH=$PIECE(Y,U)
SET DV=DG
SET DWPK="FM"
SET (DIC,Y)=DIE_DA_",DV"
SET DWO="ABCDE IJLMPRSTU"_$EXTRACT("Y",DUZ(0)="@")
if '$DATA(DIWESUB)
SET DIWESUB=DH
DO A
if '$DATA(DE(1,0))
GOTO W
+3 SET X=DE(1,0)
SET DWI=X?1"/".E
SET @(DIC_"0)")=DWLC
if DWI
SET X=$EXTRACT(X,2,999)
IF X?1"+".E
SET X=$EXTRACT(X,2,999)
+4 IF '$TEST
if 'DWI&DWLC
GOTO W
if DWLC
KILL @(Y_")")
SET DWLC=0
if X="@"
QUIT
+5 IF X?1"^".E
SET DIW=DIC
SET DICMX="S DWLC=DWLC+1,"_DIC_",DWLC,0)=X"
SET DIWL=DWLC
XECUTE $EXTRACT(X,2,999)
SET DIC=DIW
if DIWL-DWLC
SET X=""
KILL DICMX,DIWL,DIW
+6 if X]""
SET DWLC=DWLC+1
SET @(DIC_"DWLC,0)=X")
if DWI
GOTO X
W WRITE !?DL+DL-2
+1 ;UNEDITABLE W-P
SET Z=+$PIECE($GET(DC),U,2)
SET Z=$SELECT(Z:$PIECE($GET(^DD(Z,.01,0)),U,2),1:"")
IF Z["I"
IF DWLC
WRITE !,$$EZBLD^DIALOG(3090,DH),!
SET I=DWLC
SET J=1
DO LL^DIWE1
GOTO Q
+2 WRITE DH_":"
NEW DIET
IF Z["a"
IF $GET(DV)]""
IF $GET(DIC)["DV"
MERGE DIET=@$$CREF^DILF(DIC)
+3 GOTO OPT
+4 ;
A if $EXTRACT(DIC,$LENGTH(DIC))'=","
SET DIC=DIC_","
if '$DATA(DWO)
SET DWO="ABCDE IJLMPRSTU"_$EXTRACT(" Y",$SELECT($GET(DUZ(0))="@":2,1:1))
+1 if $GET(DWDISABL)]""
SET DWO=$TRANSLATE(DWO,DWDISABL,$JUSTIFY("",$LENGTH(DWDISABL)))
+2 IF $DATA(^VA(200,0))#2
IF ^(0)'["NEW PERSON"
IF '$DATA(DDS)
Begin DoDot:1
+3 WRITE !!?2,$CHAR(7)_"WARNING: You appear to have a file #200 stored at ^VA(200),"
+4 WRITE !?11,"but it is not named 'NEW PERSON.' I will assume your"
+5 WRITE !?11,"preferred editor is the Line Editor.",!
End DoDot:1
+6 KILL DWL,DIWE
SET U="^"
SET DIWPT=$SELECT('$DATA(^VA(200,0)):"",^(0)'["NEW PERSON":"",'$DATA(^VA(200,+DUZ,1)):"",1:$PIECE(^(1),U,4))
+7 SET DIWE=$SELECT('$DATA(^VA(200,0)):0,^(0)'["NEW PERSON":0,'$DATA(^VA(200,+DUZ,1)):0,1:+$PIECE(^(1),U,5))
SET DIWE=$SELECT($DATA(^DIST(1.2,DIWE,0)):DIWE,1:0)
if 'DIWE
SET DIWE=$SELECT($DATA(DDS)#2:2,1:1)
+8 SET @("J=$O("_DIC_"0))>0")
IF '$DATA(^(0))!'J
SET ^(0)=""
+9 SET DWHD=^(0)_U
SET DWLC=+$PIECE(DWHD,U,3)
SET DWLW=$SELECT($DATA(DWLW):DWLW,1:245)
IF J
if DWLC-$PIECE(DWHD,U,4)!'DWLC!'$DATA(^(DWLC))
DO REPACK
+10 SET DWPK=$SELECT($DATA(DWPK):DWPK,1:2)
SET DWLR=245
SET DWLC=$SELECT('DWLC:+DWHD,1:DWLC)
+11 QUIT
+12 ;
REPACK KILL ^UTILITY($JOB,"W")
SET J=0
FOR I=0:0
SET @("J=$O("_DIC_"J))")
if J'>0
QUIT
if $DATA(^(J,0))
SET I=I+1
SET ^UTILITY($JOB,"W",I)=^(0)
if '$DATA(ZTQUEUED)
WRITE "."
+1 KILL @($EXTRACT(DIC,1,$LENGTH(DIC)-1)_")")
FOR J=1:1:I
SET @(DIC_"J,0)=^UTILITY($J,""W"",J)")
if '$DATA(ZTQUEUED)
WRITE "."
+2 KILL ^UTILITY($JOB,"W")
SET DWLC=I
SET $PIECE(@(DIC_"0)"),U,3,4)=I_U_I
QUIT
+3 ;
X if $DATA(DIWE(1))
QUIT
IF $DATA(DT)[0
DO NOW^%DTC
SET DT=X
KILL %I
+1 ;AUDIT Word -Processing, but not if we didn't touch it
IF $DATA(DIET)>9
IF $GET(DP)
IF $GET(DIFLD(1))
IF '$GET(DIDNEDIT)
DO WP^DIET(DP,DIFLD(1),$$IENS^DILF(.DA),"DIET")
+2 IF @("$O("_DIC_"0))'>0")
KILL @($EXTRACT(DIC,1,$LENGTH(DIC)-1)_")")
GOTO Q
+3 ;Has already been updated.
IF $DATA(@(DIC_"0)"))#2
if $PIECE(^(0),U,5)?7N.1P.6N
GOTO Q
+4 SET ^(0)=$PIECE(DWHD,U,1,2)_U_DWLC_U_DWLC_U_DT_U_$PIECE(DWHD,U,6,9)
+5 if $DATA(DDS)
DO INIT^DDGLIB0()
Q LOCK @("-"_DIC_"0)")
KILL DW2,DW3,DIWPT,DWO,DWLR,DWHD,DWL,DWPK,DWI,DWJ,DWLC
+1 ;**CCO/NI CLEAN UP VARIABLES
KILL Y,Z,DWAFT,DWLW,DIW,D,DIWE,DIWETXT,DIWESUB,DDWLMAR,DDWRMAR,DDWFLAGS,DWDISABL,DDWAUTO,DDWTAB,DC,DIWEX1
