Routine: DICRW

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,"

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,"

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 %"

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

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 %"

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

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

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

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)_")"

DICRW.m