- 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
