DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;20MAR2006
;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
S D NOW^%DTC S DIADT=+$J(%,0,4) K %,DW G Q:DRS<5 R !,"STORE THESE FIELDS IN TEMPLATE: ",X:DTIME S:'$T DTOUT=1 G Q:X="" S DIC(0)="LZSEQ",DLAYGO=0 D T K DLAYGO,DIC I Y<0 G S:X'[U K DR G Q
S X=$P(^(0),U,6) I DUZ(0)'["@",X]"" F %=1:1 I DUZ(0)[$E(X,%) Q:%'>$L(X) W !?7,$C(7),"YOU HAVE NO 'WRITE ACCESS' TO THIS TEMPLATE",! G S
S DW=$S('$D(^("ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),%=0,X=$P(Y,U,2)
I $O(^(0))]"" W $C(7),!,X_" TEMPLATE ALREADY EXISTS.... OK TO REPLACE" D YN^DICN W ! G S:%-1 L +^DIE(+Y) S %Y="" F %X=0:0 S %Y=$O(^DIE(+Y,%Y)) Q:%Y="" K:",%D,ROUOLD,W,"'[(","_%Y_",") ^(%Y)
S ^DIE(+Y,0)=X_U_DIADT_U_$S('%:DUZ(0),1:$P(Y(0),U,3))_U_DI_U_DUZ_U_$S('%:DUZ(0),1:$P(Y(0),U,6))_U_DT,^DIE("F"_DI,X,+Y)=1 L -^DIE(+Y)
M S %X="DR(",%Y="^DIE(+Y,""DR""," D %XY^%RCR M ^DIE(+Y,"DIAB")=^UTILITY($J)
S X=DW,DP=DIA("P"),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ S DR(1,DIA("P"))=U_DNM
Q K DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y Q
;
ALL ;Called by DIETED, DIA
S %=DI,^UTILITY($J,1,F,%,DIAP\1000)="ALL" K DA D G UP^DIA:F,S:$D(DRS) Q
.N DIA1 S DIA1=DIARLVL D A
;
RANGE ;called by DIA, DIE17, DIETED
N DIA1 S DIA1=F+1 S %=DI I X>0 S Y=X-.000001 G B
A S Y=0
B S DA="",X=0
G S DG=Y
DR S Y=$O(^DD(%,Y)) S:Y="" Y=-1 I $D(D(F)),Y'>0!(Y>D(F)) D DG:X Q
I Y'>0 D DG:X S:$D(DR(DIA1,%))[0 DR(DIA1,%)=DA Q
I $D(^(Y,0)),X X DIC("S") G G:$T D DG G DR
X DIC("S") E G DR
S X=Y G G
;
DG S DA=DA_$E(";",1,$L(DA))_X_$P(":"_DG,U,X'=DG)
S DQ=0 F S DQ=$O(^DD(%,"SB",DQ)) Q:DQ="" S DP=$O(^(DQ,0)) I DP'<X,DP'>DG S Y(F,DQ)=""
S DQ=-1
Y S X=$O(Y(F,0)) I X>0 K Y(F,X) S DA(F)=DA,Y(F)=Y,%(F)=%,F=F+1,DIA1=DIA1+1,%=X D A S F=F-1,DIA1=DIA1-1,%=%(F),Y=Y(F),DA=DA(F) G Y
S X="",DG=0 K DP Q
;
TEMP ;
S DIC(0)="ZSEQ" D T K DIC Q:$D(DTOUT) G DB:Y<0
S %=$P(Y(0),U,6) G ED:DUZ(0)="@"!'$L(%) F X=1:1:$L(%) I DUZ(0)[$E(%,X) G ED
GT I $G(^("ROU"))[U S DR(1,DIA("P"))=^("ROU")
E S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR
S $P(^DIE(+Y,0),U,7)=DT
Q
;
T K DIC("W") S D="F"_DI,X=$P(X,"]",1),X=$P(X,"[",1)_$P(X,"[",2),DIC="^DIE(",DIC("S")="I $P(^(0),U,4)=DI"_$P(" S %=$P(^(0),U,3) F DW=1:1:$L(%) I DUZ(0)[$E(%,DW) Q",9,DUZ(0)'="@") G IX^DIC
;
ED I Y<1 G GT
S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' INPUT TEMPLATE" D YN^DICN G GT:%-1
S DIE="^DIE(",DA=+Y,DR=".01;3;6" D ^DIE K DR I '$D(DA) S DB=0 G DB
S:$D(^DIE(DA,"DR"))#2 ^("DR",1,J(0))=^("DR")
S DIAA=DA,DRS=9,DIAT=$S($D(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"")
M DI=^DIE(DA,"DIAB")
S F=0,(DIARTLVL,DB)=1,DIAO=0 F DXS=1:1 Q:'$D(DR(99,DXS))
DB S DI=J(0) G ^DIA
DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;20MAR2006
+1 ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
S DO NOW^%DTC
SET DIADT=+$JUSTIFY(%,0,4)
KILL %,DW
IF DRS<5
GOTO Q
READ !,"STORE THESE FIELDS IN TEMPLATE: ",X:DTIME
IF '$TEST
SET DTOUT=1
IF X=""
GOTO Q
SET DIC(0)="LZSEQ"
SET DLAYGO=0
DO T
KILL DLAYGO,DIC
IF Y<0
IF X'[U
GOTO S
KILL DR
GOTO Q
+1 SET X=$PIECE(^(0),U,6)
IF DUZ(0)'["@"
IF X]""
FOR %=1:1
IF DUZ(0)[$EXTRACT(X,%)
IF %'>$LENGTH(X)
QUIT
WRITE !?7,$CHAR(7),"YOU HAVE NO 'WRITE ACCESS' TO THIS TEMPLATE",!
GOTO S
+2 SET DW=$SELECT('$DATA(^("ROU")):1,^("ROU")'[U:1,$DATA(^("ROUOLD")):^("ROUOLD"),1:1)
SET %=0
SET X=$PIECE(Y,U,2)
+3 IF $ORDER(^(0))]""
WRITE $CHAR(7),!,X_" TEMPLATE ALREADY EXISTS.... OK TO REPLACE"
DO YN^DICN
WRITE !
IF %-1
GOTO S
LOCK +^DIE(+Y)
SET %Y=""
FOR %X=0:0
SET %Y=$ORDER(^DIE(+Y,%Y))
IF %Y=""
QUIT
IF ",%D,ROUOLD,W,"'[(","_%Y_",")
KILL ^(%Y)
+4 SET ^DIE(+Y,0)=X_U_DIADT_U_$SELECT('%:DUZ(0),1:$PIECE(Y(0),U,3))_U_DI_U_DUZ_U_$SELECT('%:DUZ(0),1:$PIECE(Y(0),U,6))_U_DT
SET ^DIE("F"_DI,X,+Y)=1
LOCK -^DIE(+Y)
M SET %X="DR("
SET %Y="^DIE(+Y,""DR"","
DO %XY^%RCR
MERGE ^DIE(+Y,"DIAB")=^UTILITY($JOB)
+1 SET X=DW
SET DP=DIA("P")
SET DMAX=^DD("ROU")
IF X'=1
IF $DATA(^DD("OS",DISYS,"ZS"))
DO EN^DIEZ
SET DR(1,DIA("P"))=U_DNM
Q KILL DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y
QUIT
+1 ;
ALL ;Called by DIETED, DIA
+1 SET %=DI
SET ^UTILITY($JOB,1,F,%,DIAP\1000)="ALL"
KILL DA
Begin DoDot:1
+2 NEW DIA1
SET DIA1=DIARLVL
DO A
End DoDot:1
IF F
GOTO UP^DIA
IF $DATA(DRS)
GOTO S
QUIT
+3 ;
RANGE ;called by DIA, DIE17, DIETED
+1 NEW DIA1
SET DIA1=F+1
SET %=DI
IF X>0
SET Y=X-.000001
GOTO B
A SET Y=0
B SET DA=""
SET X=0
G SET DG=Y
DR SET Y=$ORDER(^DD(%,Y))
IF Y=""
SET Y=-1
IF $DATA(D(F))
IF Y'>0!(Y>D(F))
IF X
DO DG
QUIT
+1 IF Y'>0
IF X
DO DG
IF $DATA(DR(DIA1,%))[0
SET DR(DIA1,%)=DA
QUIT
+2 IF $DATA(^(Y,0))
IF X
XECUTE DIC("S")
IF $TEST
GOTO G
DO DG
GOTO DR
+3 XECUTE DIC("S")
IF '$TEST
GOTO DR
+4 SET X=Y
GOTO G
+5 ;
DG SET DA=DA_$EXTRACT(";",1,$LENGTH(DA))_X_$PIECE(":"_DG,U,X'=DG)
+1 SET DQ=0
FOR
SET DQ=$ORDER(^DD(%,"SB",DQ))
IF DQ=""
QUIT
SET DP=$ORDER(^(DQ,0))
IF DP'<X
IF DP'>DG
SET Y(F,DQ)=""
+2 SET DQ=-1
Y SET X=$ORDER(Y(F,0))
IF X>0
KILL Y(F,X)
SET DA(F)=DA
SET Y(F)=Y
SET %(F)=%
SET F=F+1
SET DIA1=DIA1+1
SET %=X
DO A
SET F=F-1
SET DIA1=DIA1-1
SET %=%(F)
SET Y=Y(F)
SET DA=DA(F)
GOTO Y
+1 SET X=""
SET DG=0
KILL DP
QUIT
+2 ;
TEMP ;
+1 SET DIC(0)="ZSEQ"
DO T
KILL DIC
IF $DATA(DTOUT)
QUIT
IF Y<0
GOTO DB
+2 SET %=$PIECE(Y(0),U,6)
IF DUZ(0)="@"!'$LENGTH(%)
GOTO ED
FOR X=1:1:$LENGTH(%)
IF DUZ(0)[$EXTRACT(%,X)
GOTO ED
GT IF $GET(^("ROU"))[U
SET DR(1,DIA("P"))=^("ROU")
+1 IF '$TEST
IF $DATA(^("W"))
SET DIE("W")=^("W")
SET %X="^DIE(+Y,""DR"","
SET %Y="DR("
DO %XY^%RCR
+2 SET $PIECE(^DIE(+Y,0),U,7)=DT
+3 QUIT
+4 ;
T KILL DIC("W")
SET D="F"_DI
SET X=$PIECE(X,"]",1)
SET X=$PIECE(X,"[",1)_$PIECE(X,"[",2)
SET DIC="^DIE("
SET DIC("S")="I $P(^(0),U,4)=DI"_$PIECE(" S %=$P(^(0),U,3) F DW=1:1:$L(%) I DUZ(0)[$E(%,DW) Q",9,DUZ(0)'="@")
GOTO IX^DIC
+1 ;
ED IF Y<1
GOTO GT
+1 SET %=2
WRITE !,"WANT TO EDIT '",$PIECE(Y,U,2),"' INPUT TEMPLATE"
DO YN^DICN
IF %-1
GOTO GT
+2 SET DIE="^DIE("
SET DA=+Y
SET DR=".01;3;6"
DO ^DIE
KILL DR
IF '$DATA(DA)
SET DB=0
GOTO DB
+3 IF $DATA(^DIE(DA,"DR"))#2
SET ^("DR",1,J(0))=^("DR")
+4 SET DIAA=DA
SET DRS=9
SET DIAT=$SELECT($DATA(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"")
+5 MERGE DI=^DIE(DA,"DIAB")
+6 SET F=0
SET (DIARTLVL,DB)=1
SET DIAO=0
FOR DXS=1:1
IF '$DATA(DR(99,DXS))
QUIT
DB SET DI=J(0)
GOTO ^DIA
