DICRW ;SFISC/XAK-SELECT A FILE ;8/11/06 05:51
;;22.0;VA FileMan;**149**;Mar 30, 1999;Build 2
;Per VHA Directive 10-93-142, this routine should not be modified.
R D DT S D="OUTPUT FROM",DIC(0)="QEI",DIA=$S($D(^DISV(DUZ,"^DIC(")):^("^DIC("),1:"")
D R1,DIC K DIAC,DIFILE,DIC("S") Q:$D(DTOUT) G R:'$T,AU:+Y=1.1,A:+Y=.6
R2 I DUZ(0)'="@" S DICS="I 1 Q:'$D(^(8)) F DW=1:1:$L(^(8)) I DUZ(0)[$E(^(8),DW) Q"
K DIA Q
;
AU S D="AUDIT FROM",DIC(0)="QEI" S:'$D(DIC("S")) DIC("S")="I Y>1.1"
S:DIA ^DISV(DUZ,"^DIC(")=DIA D DIC Q:'$D(DIC) G AU:Y<0
I '$D(DDA),'$D(^DIA(+Y,0))#2 W $C(7)," NO AUDIT ENTRIES" G AU
S DIA=+Y,Y="1.1^"_$P(Y,U,2)_" AUDIT",DIC="^DIA(DIA,"
Q
A S:'$D(DIC("S")) DIC("S")="S DIFILE=Y,DIAC=""DD"" D ^DIAC I %",DDA=""
D AU Q:'$D(DIC)
S %=$P(^DIC(DIA,0),U),Y=DIA D SUB I DIA'>0!$D(DTOUT)!$D(DUOUT) K DIC Q
I '$D(^DDA(DIA,0)) W !," No DD AUDIT entries!" K DIC Q
S Y=".6^"_$P(Y,U,2)_"DD AUDIT",DIC="^DDA(DIA,"
Q
SUB I $D(DIT) S L=L+1,DFL(L)=$O(^DD(+Y,0,"NM","")),(DFF,DFF(L))=+Y,Y=-1
S DIC="^DD("_Y_"," Q:$O(^DD(Y,"SB",0))'>0 Q:$D(DIT)
S DIC(0)="AEQIZ",DIC("A")="Select "_%_" SUB-FILE: "
S DIC("S")="I $P(^(0),U,2)" D ^DIC Q:Y<0!$D(DTOUT) S Y=+$P(Y(0),U,2)
S DIA=Y,%=$P($P(^DD(DIA,0),U)," SUB-FIELD")
I $D(DIT) S X=$P($P(Y(0),U,4),";",1),DSUB(L)=$S(X:X,1:""""_X_"""")_","
G SUB
R1 S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
Q
DT ;
I $D(IO)#2,$D(IO(0))#2,IO=IO(0),IO=""
E W:'$G(DIQUIET) !
DTNOLF ; DT entry point without doing a line feed.
S:$D(DUZ)#2-1 DUZ=0 S:$D(DUZ(0))#2-1 DUZ(0)="" S X=DUZ(0)="@" D 1
I '$D(DTIME) S DTIME=300
I '$D(DILOCKTM) S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;DI*146
K %DT,DT S:$D(IO(0))[0 IO(0)=$I D NOW^%DTC S DT=X,U="^"
K DIK,DIC,%I,DICS Q
;
0 S X=0
1 D:'$D(DISYS) OS^DII
Q
W D DT S D=$S('$D(DDS1):"INPUT TO",1:DDS1),DIC(0)=$E("L",$D(DLAYGO)>0)_"EQI"
D W1,DIC Q:$T!($D(DTOUT)) G W:'$P(Y,U,3) K DIC Q
W1 S DIC("S")="I Y>.19,Y-1,Y-1.1,Y-.6,Y-.403,Y-.404,Y-.31 S DIFILE=+Y,DIAC=""WR"" D ^DIAC I %"
Q
DIC W ! S U="^",D=D_" WHAT FILE: ",DIC="^DIC("
I DUZ(0)'="@",DIC(0)'["L",$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) S DIC=$S($D(^VA(200,"AFOF")):"^VA(200,",1:DIC_"3,")_"DUZ,""FOF"","
I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_Y_",0)")) X:$D(DIC("S")) DIC("S") I S Y=Y_U_$P(^DIC(Y,0),U),D=D_$P(Y,U,2)_"// "
W D S %=$T R X:DTIME E W $C(7) S X=U,DTOUT=1,Y=-1 K DIC Q
I '$D(@(DIC_"0)")) W " There are no selectable files." K DIC S Y=-1 Q
S:DIC["FOF" DIC(0)=DIC(0)_"O" I X="",% G WW
S DIC("W")=$P($T(WW1),";",3) D ^DIC I $D(DTOUT) K DIC Q
GOT I $D(^DIC(+Y,0,"GL")) K DIC S DIC=^("GL") Q
I U[X K DIC
Q
WW S A9=$P($T(WW1),";",3) X A9
K A9
G GOT
;
D D DT S D="MODIFY",DIC(0)="LQEI",DIC("S")="I Y'<2 S DIFILE=+Y,DIAC=""DD"" D ^DIAC I %"
D DIC S:DUZ(0)'="@" DICS="I 1 Q:'$D(^(9)) Q:^(9)=U F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q"
Q:$T!($D(DTOUT)) G D:'$P(Y,U,3) K DIC
Q
DIAR ;
D DT S D=$S($D(DIAX):"EXTRACT",1:"ARCHIVE")_" FROM",DIC(0)="QEI" D R1 S DIC("S")="I Y'<2 "_DIC("S")
D DIC G R2:$D(DTOUT)!(X="^")!(X="")!(Y>0&($P($G(^DD(+Y,0,"DI")),U)'["Y"))
W:$P($G(^DD(+Y,0,"DI")),U)["Y" !,$C(7),"SORRY, THIS IS ALREADY AN ARCHIVE FILE!"
G DIAR
Q
T ; COMP/MERGE
D DT S D="COMPARE ENTRIES IN",DIC=1,DIC(0)="QEI" D W1,DIC Q:$T!($D(DTOUT)) G T
;
WW1 ;;W:$X>53 !?9 I Y-1.1,Y-.6,$D(^DIC(Y,0,"GL")),^("GL")'["[",$D(@(^("GL")_"0)")) S %=+$P(^(0),U,4) W ?40," ("_%_" entr"_$P("ies^y",U,%=1+1)_")"
DICRW ;SFISC/XAK-SELECT A FILE ;8/11/06 05:51
+1 ;;22.0;VA FileMan;**149**;Mar 30, 1999;Build 2
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
R DO DT
SET D="OUTPUT FROM"
SET DIC(0)="QEI"
SET DIA=$SELECT($DATA(^DISV(DUZ,"^DIC(")):^("^DIC("),1:"")
+1 DO R1
DO DIC
KILL DIAC,DIFILE,DIC("S")
IF $DATA(DTOUT)
QUIT
IF '$TEST
GOTO R
IF +Y=1.1
GOTO AU
IF +Y=.6
GOTO A
R2 IF DUZ(0)'="@"
SET DICS="I 1 Q:'$D(^(8)) F DW=1:1:$L(^(8)) I DUZ(0)[$E(^(8),DW) Q"
+1 KILL DIA
QUIT
+2 ;
AU SET D="AUDIT FROM"
SET DIC(0)="QEI"
IF '$DATA(DIC("S"))
SET DIC("S")="I Y>1.1"
+1 IF DIA
SET ^DISV(DUZ,"^DIC(")=DIA
DO DIC
IF '$DATA(DIC)
QUIT
IF Y<0
GOTO AU
+2 IF '$DATA(DDA)
IF '$DATA(^DIA(+Y,0))#2
WRITE $CHAR(7)," NO AUDIT ENTRIES"
GOTO AU
+3 SET DIA=+Y
SET Y="1.1^"_$PIECE(Y,U,2)_" AUDIT"
SET DIC="^DIA(DIA,"
+4 QUIT
A IF '$DATA(DIC("S"))
SET DIC("S")="S DIFILE=Y,DIAC=""DD"" D ^DIAC I %"
SET DDA=""
+1 DO AU
IF '$DATA(DIC)
QUIT
+2 SET %=$PIECE(^DIC(DIA,0),U)
SET Y=DIA
DO SUB
IF DIA'>0!$DATA(DTOUT)!$DATA(DUOUT)
KILL DIC
QUIT
+3 IF '$DATA(^DDA(DIA,0))
WRITE !," No DD AUDIT entries!"
KILL DIC
QUIT
+4 SET Y=".6^"_$PIECE(Y,U,2)_"DD AUDIT"
SET DIC="^DDA(DIA,"
+5 QUIT
SUB IF $DATA(DIT)
SET L=L+1
SET DFL(L)=$ORDER(^DD(+Y,0,"NM",""))
SET (DFF,DFF(L))=+Y
SET Y=-1
+1 SET DIC="^DD("_Y_","
IF $ORDER(^DD(Y,"SB",0))'>0
QUIT
IF $DATA(DIT)
QUIT
+2 SET DIC(0)="AEQIZ"
SET DIC("A")="Select "_%_" SUB-FILE: "
+3 SET DIC("S")="I $P(^(0),U,2)"
DO ^DIC
IF Y<0!$DATA(DTOUT)
QUIT
SET Y=+$PIECE(Y(0),U,2)
+4 SET DIA=Y
SET %=$PIECE($PIECE(^DD(DIA,0),U)," SUB-FIELD")
+5 IF $DATA(DIT)
SET X=$PIECE($PIECE(Y(0),U,4),";",1)
SET DSUB(L)=$SELECT(X:X,1:""""_X_"""")_","
+6 GOTO SUB
R1 SET DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
+1 QUIT
DT ;
+1 IF $DATA(IO)#2
IF $DATA(IO(0))#2
IF IO=IO(0)
IF IO=""
+2 IF '$TEST
IF '$GET(DIQUIET)
WRITE !
DTNOLF ; DT entry point without doing a line feed.
+1 IF $DATA(DUZ)#2-1
SET DUZ=0
IF $DATA(DUZ(0))#2-1
SET DUZ(0)=""
SET X=DUZ(0)="@"
DO 1
+2 IF '$DATA(DTIME)
SET DTIME=300
+3 ;DI*146
IF '$DATA(DILOCKTM)
SET DILOCKTM=+$GET(^DD("DILOCKTM"),1)
+4 KILL %DT,DT
IF $DATA(IO(0))[0
SET IO(0)=$IO
DO NOW^%DTC
SET DT=X
SET U="^"
+5 KILL DIK,DIC,%I,DICS
QUIT
+6 ;
0 SET X=0
1 IF '$DATA(DISYS)
DO OS^DII
+1 QUIT
W DO DT
SET D=$SELECT('$DATA(DDS1):"INPUT TO",1:DDS1)
SET DIC(0)=$EXTRACT("L",$DATA(DLAYGO)>0)_"EQI"
+1 DO W1
DO DIC
IF $TEST!($DATA(DTOUT))
QUIT
IF '$PIECE(Y,U,3)
GOTO W
KILL DIC
QUIT
W1 SET DIC("S")="I Y>.19,Y-1,Y-1.1,Y-.6,Y-.403,Y-.404,Y-.31 S DIFILE=+Y,DIAC=""WR"" D ^DIAC I %"
+1 QUIT
DIC WRITE !
SET U="^"
SET D=D_" WHAT FILE: "
SET DIC="^DIC("
+1 IF DUZ(0)'="@"
IF DIC(0)'["L"
IF $SELECT($DATA(^VA(200,"AFOF")):1,1:$DATA(^DIC(3,"AFOF")))
SET DIC=$SELECT($DATA(^VA(200,"AFOF")):"^VA(200,",1:DIC_"3,")_"DUZ,""FOF"","
+2 IF $DATA(^DISV(DUZ,DIC))
SET Y=^(DIC)
IF $DATA(@(DIC_Y_",0)"))
IF $DATA(DIC("S"))
XECUTE DIC("S")
IF $TEST
SET Y=Y_U_$PIECE(^DIC(Y,0),U)
SET D=D_$PIECE(Y,U,2)_"// "
+3 WRITE D
SET %=$TEST
READ X:DTIME
IF '$TEST
WRITE $CHAR(7)
SET X=U
SET DTOUT=1
SET Y=-1
KILL DIC
QUIT
+4 IF '$DATA(@(DIC_"0)"))
WRITE " There are no selectable files."
KILL DIC
SET Y=-1
QUIT
+5 IF DIC["FOF"
SET DIC(0)=DIC(0)_"O"
IF X=""
IF %
GOTO WW
+6 SET DIC("W")=$PIECE($TEXT(WW1),";",3)
DO ^DIC
IF $DATA(DTOUT)
KILL DIC
QUIT
GOT IF $DATA(^DIC(+Y,0,"GL"))
KILL DIC
SET DIC=^("GL")
QUIT
+1 IF U[X
KILL DIC
+2 QUIT
WW SET A9=$PIECE($TEXT(WW1),";",3)
XECUTE A9
+1 KILL A9
+2 GOTO GOT
+3 ;
D DO DT
SET D="MODIFY"
SET DIC(0)="LQEI"
SET DIC("S")="I Y'<2 S DIFILE=+Y,DIAC=""DD"" D ^DIAC I %"
+1 DO DIC
IF DUZ(0)'="@"
SET DICS="I 1 Q:'$D(^(9)) Q:^(9)=U F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q"
+2 IF $TEST!($DATA(DTOUT))
QUIT
IF '$PIECE(Y,U,3)
GOTO D
KILL DIC
+3 QUIT
DIAR ;
+1 DO DT
SET D=$SELECT($DATA(DIAX):"EXTRACT",1:"ARCHIVE")_" FROM"
SET DIC(0)="QEI"
DO R1
SET DIC("S")="I Y'<2 "_DIC("S")
+2 DO DIC
IF $DATA(DTOUT)!(X="^")!(X="")!(Y>0&($PIECE($GET(^DD(+Y,0,"DI")),U)'["Y"))
GOTO R2
+3 IF $PIECE($GET(^DD(+Y,0,"DI")),U)["Y"
WRITE !,$CHAR(7),"SORRY, THIS IS ALREADY AN ARCHIVE FILE!"
+4 GOTO DIAR
+5 QUIT
T ; COMP/MERGE
+1 DO DT
SET D="COMPARE ENTRIES IN"
SET DIC=1
SET DIC(0)="QEI"
DO W1
DO DIC
IF $TEST!($DATA(DTOUT))
QUIT
GOTO T
+2 ;
WW1 ;;W:$X>53 !?9 I Y-1.1,Y-.6,$DICRW_source.html#xD">D(^DICRW_source.html#xD">DIC(Y,0,"GL")),^("GL")'["[",$DICRW_source.html#xD">D(@(^("GL")_"0)")) S %=+$P(^(0),U,4) W ?40," ("_%_" entr"_$P("ies^y",U,%=1+1)_")"
