Routine: DIV

DIV ;SFISC/GFT-VERIFY FLDS ;10:06 AM  28 Jun 1999 [ 04/02/2003   8:25 AM ]

 ;;22.0;VA FileMan;**1001**;APR 1, 2003

 ;;22.0;VA FileMan;**7**;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 N DIUTIL,DIVDAT,DIVFIL,DIVMODE,DIVPG,POP S DIUTIL="VERIFY FIELDS"

K J

 S Q="""",S=";",V=0,P=0,I(0)=DIU,@("(A,J(0))=+$P("_DIU_"0),U,2)")

 I $O(^(0))'>0 W $C(7),"  NO ENTRIES ON FILE!" Q

DIC S DIC="^DD(A,",DIC(0)="EZ",DIC("W")="W:$P(^(0),U,2) ""  (multiple)"""

 S DIC("S")="S %=$P(^(0),U,2) I %'[""C"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W"")"

 W !,"VERIFY WHICH "_$P(^DD(A,0),U)_": " R X:DTIME Q:U[X

 I X="ALL" D ALL G Q:$D(DIRUT) I Y S DIVMODE="A" D DEVSEL G:$G(POP) Q D INIT,FLDS G Q^DIVR:DQI'>0!$D(DIRUT)

 D ^DIC K DQI,^UTILITY("DIVR",$J)

 I Y<0 W:X?1."?" !?3,"You may enter ALL to verify every field at this level of the file.",! G DIC

 S DR=$P(Y(0),U,2) I DR S J(V)=A,P=+Y,V=V+1,A=+DR,I(V)=$P($P(Y(0),U,4),S,1) S:+I(V)'=I(V) I(V)=Q_I(V)_Q G DIC

 D DEVSEL G:$G(POP) Q D INIT

1 F T="N","D","P","S","V","F" Q:DR[T

 F W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K" I T[$E(W) S:W="K" W="MUMPS" W "   ",W Q

 K DA S DIVZ=$P(Y(0),U,3),DDC=$P(Y(0),U,5,99),(DIFLD,DA)=+Y

 G ^DIVR

Q K DIR,DIRUT,N,P,Q,S,V,C

ALL S DIR(0)="Y",DIR("??")="^D H^DIV"

 S DIR("A")="DO YOU MEAN ALL THE FIELDS IN THE FILE"

 D ^DIR K DIR S X="ALL"

FLDS S DQI=0 F  S DQI=$O(^DD(A,DQI)) Q:DQI'>0  S Y=DQI,Y(0)=^(Y,0),DR=$P(Y(0),U,2) D  Q:$D(DIRUT)

 .I DR,$P(^DD(+DR,.01,0),U,2)["W" Q

 .I DR D NEXTLVL Q

 .I DR'["C" D  Q:$D(DIRUT)  W "--",$P(Y(0),U),"--" D 1 Q

 .. N DIVI F DIVI=1:1:3 D LF^DIVR Q:$D(DIRUT)

NEXTLVL ;

 N A,P,DE,DA,DQI,I,J,V S DQI=0

 S A=+DR,P=+Y N Y,DR D IJ^DIVU(A)

 D FLDS

H W !!?5,"YES means that every field at this level in the file will"

 W !?5,"be checked to see if it conforms to the input transform."

 W !!?5,"NO means that ALL will be used to lookup a field in the"

 W !?5,"file which begins with the letters ALL, e.g., ALLERGIES."

VER(DIVRFILE,DIVRREC,DIVRDR,DIVROUT) ;

 ;DIVRFILE = (sub)file number

 ;DIVRREC = template, or ien-string of records to be verified

 ;DIVRDR = list of fields to be verified (defaults to ALL)

 ;DIVROUT = output array listing the records that had problems

 G ^DIVR1

DIVROUT I $G(DIVROUT)="" D X Q

 I $E(DIVROUT)="[" D  Q

 . N Y,COUNT,Z

 . D DIBT^DIVU(DIVROUT,.Y,DIVRFI0) Q:Y'>0

 . K ^DIBT(+Y,1)

 . S (COUNT,Z)=0

 . F  S Z=$O(^TMP("DIVR1",$J,Z)) Q:Z=""  S COUNT=COUNT+1,^DIBT(+Y,1,Z)=""

 . I COUNT S ^DIBT(+Y,"QR")=DT_U_COUNT

 . D X

 M @DIVROUT@(1)=^TMP("DIVR1",$J)

X K ^TMP("DIVR1",$J)

INIT ;Get header info and print first header

 N %,%H,X,Y

 K DIRUT

 S %H=$H D YX^%DTC

 S DIVDAT=$P(Y,"@")_"  "_$P($P(Y,"@",2),":",1,2)_"    PAGE "

 I $D(^DIC(A,0))#2 S DIVFIL=$P(^(0),U)_" FILE (#"_A_")"

 E  I $D(^DD(A,0,"NM")) S DIVFIL=$O(^("NM",""))_" SUB-FILE (#"_A_")"

 E  S DIVFIL=""

 U IO

 W:IOST?1"C-".E @IOF

 D HDR^DIVR

DEVSEL ;Prompt for device

 D  Q:$G(POP)

 . N %ZIS,A,I,J,T,V,X,Y,Z

 . S %ZIS=$E("Q",$D(^%ZTSK)>0)

 . W ! D ^%ZIS

 I $D(IO("Q")),$D(^%ZTSK) D  S POP=1

 . S ZTRTN="ENQUEUE^DIV"

 . S ZTDESC="Verify Fields Report for File #"_A

 . N %,DIVA,DIVI,DIVJ,DIVT,DIVV,DIVY,DIVZ

 . M DIVA=A,DIVI=I,DIVJ=J,DIVT=T,DIVV=V,DIVY=Y,DIVZ=Z

 . F %="DIU","DIUTIL","DIVMODE","DIVA","DIVI","DIVI(","DIVJ","DIVJ(","DIVV","DIVZ" S ZTSAVE(%)=""

 . I $G(DIVMODE)'="A" F %="DIVY","DIVY(","DR" S ZTSAVE(%)=""

 . I $G(DIVMODE)="C" F %="DA","DDC","DIFLD","DIVT" S ZTSAVE(%)=""

 . D ^%ZTLOAD

 . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!

 . E  W !,"Report canceled!",!

 . K ZTSK

 . S IOP="HOME" D ^%ZIS

ENQUEUE ;Entry point for queued reports

 M A=DIVA,I=DIVI,J=DIVJ,T=DIVT,V=DIVV,Y=DIVY,Z=DIVZ

 K DIVA,DIVI,DIVJ,DIVT,DIVV,DIVY,DIVZ

 S Q="""",S=";"

 D INIT

 I $G(DIVMODE)="A" D FLDS,Q^DIVR Q

 I $G(DIVMODE)="C" D ^DIVR Q

D 1

DIV       ;SFISC/GFT-VERIFY FLDS ;10:06 AM  28 Jun 1999 [ 04/02/2003   8:25 AM ]

 +1       ;;22.0;VA FileMan;**1001**;APR 1, 2003

 +2       ;;22.0;VA FileMan;**7**;Mar 30, 1999

 +3       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +4        NEW DIUTIL,DIVDAT,DIVFIL,DIVMODE,DIVPG,POP

           SET DIUTIL="VERIFY FIELDS"

 +5        KILL J

 +6        SET Q=""""

           SET S=";"

           SET V=0

           SET P=0

           SET I(0)=DIU

           SET @("(A,J(0))=+$P("_DIU_"0),U,2)")

 +7        IF $ORDER(^(0))'>0

               WRITE $CHAR(7),"  NO ENTRIES ON FILE!"

               QUIT

DIC        SET DIC="^DD(A,"

           SET DIC(0)="EZ"

           SET DIC("W")="W:$P(^(0),U,2) ""  (multiple)"""

 +1        SET DIC("S")="S %=$P(^(0),U,2) I %'[""C"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W"")"

 +2        WRITE !,"VERIFY WHICH "_$PIECE(^DD(A,0),U)_": "

           READ X:DTIME

           IF U[X

               QUIT

 +3        IF X="ALL"

               DO ALL

               IF $DATA(DIRUT)

                   GOTO Q

               IF Y

                   SET DIVMODE="A"

                   DO DEVSEL

                   IF $GET(POP)

                       GOTO Q

                   DO INIT

                   DO FLDS

                   IF DQI'>0!$DATA(DIRUT)

                       GOTO Q^DIVR

 +4        DO ^DIC

           KILL DQI,^UTILITY("DIVR",$JOB)

 +5        IF Y<0

               IF X?1."?"

                   WRITE !?3,"You may enter ALL to verify every field at this level of the file.",!

               GOTO DIC

 +6        SET DR=$PIECE(Y(0),U,2)

           IF DR

               SET J(V)=A

               SET P=+Y

               SET V=V+1

               SET A=+DR

               SET I(V)=$PIECE($PIECE(Y(0),U,4),S,1)

               IF +I(V)'=I(V)

                   SET I(V)=Q_I(V)_Q

               GOTO DIC

 +7        DO DEVSEL

           IF $GET(POP)

               GOTO Q

           DO INIT

1          FOR T="N","D","P","S","V","F"

               IF DR[T

                   QUIT

 +1        FOR W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K"

               IF T[$EXTRACT(W)

                   IF W="K"

                       SET W="MUMPS"

                   WRITE "   ",W

                   QUIT

 +2        KILL DA

           SET DIVZ=$PIECE(Y(0),U,3)

           SET DDC=$PIECE(Y(0),U,5,99)

           SET (DIFLD,DA)=+Y

 +3        GOTO ^DIVR

 +4       ;

Q          KILL DIR,DIRUT,N,P,Q,S,V,C

 +1        QUIT

 +2       ;

ALL        SET DIR(0)="Y"

           SET DIR("??")="^D H^DIV"

 +1        SET DIR("A")="DO YOU MEAN ALL THE FIELDS IN THE FILE"

 +2        DO ^DIR

           KILL DIR

           SET X="ALL"

 +3        QUIT

 +4       ;

FLDS       SET DQI=0

FOR

               SET DQI=$ORDER(^DD(A,DQI))

               IF DQI'>0

                   QUIT

               SET Y=DQI

               SET Y(0)=^(Y,0)

               SET DR=$PIECE(Y(0),U,2)

               Begin DoDot:1

 +1                IF DR

                       IF $PIECE(^DD(+DR,.01,0),U,2)["W"

                           QUIT

 +2                IF DR

                       DO NEXTLVL

                       QUIT

 +3                IF DR'["C"

                       Begin DoDot:2

 +4                        NEW DIVI

                           FOR DIVI=1:1:3

                               DO LF^DIVR

                               IF $DATA(DIRUT)

                                   QUIT

                       End DoDot:2

                       IF $DATA(DIRUT)

                           QUIT

                       WRITE "--",$PIECE(Y(0),U),"--"

                       DO 1

                       QUIT

               End DoDot:1

               IF $DATA(DIRUT)

                   QUIT

 +5        QUIT

NEXTLVL   ;

 +1        NEW A,P,DE,DA,DQI,I,J,V

           SET DQI=0

 +2        SET A=+DR

           SET P=+Y

           NEW Y,DR

           DO IJ^DIVU(A)

 +3        DO FLDS

 +4        QUIT

H          WRITE !!?5,"YES means that every field at this level in the file will"

 +1        WRITE !?5,"be checked to see if it conforms to the input transform."

 +2        WRITE !!?5,"NO means that ALL will be used to lookup a field in the"

 +3        WRITE !?5,"file which begins with the letters ALL, e.g., ALLERGIES."

 +4        QUIT

VER(DIVRFILE,DIVRREC,DIVRDR,DIVROUT) ;

 +1       ;DIVRFILE = (sub)file number

 +2       ;DIVRREC = template, or ien-string of records to be verified

 +3       ;DIVRDR = list of fields to be verified (defaults to ALL)

 +4       ;DIVROUT = output array listing the records that had problems

 +5        GOTO ^DIVR1

DIVROUT    IF $GET(DIVROUT)=""

               DO X

               QUIT

 +1        IF $EXTRACT(DIVROUT)="["

               Begin DoDot:1

 +2                NEW Y,COUNT,Z

 +3                DO DIBT^DIVU(DIVROUT,.Y,DIVRFI0)

                   IF Y'>0

                       QUIT

 +4                KILL ^DIBT(+Y,1)

 +5                SET (COUNT,Z)=0

 +6                FOR

                       SET Z=$ORDER(^TMP("DIVR1",$JOB,Z))

                       IF Z=""

                           QUIT

                       SET COUNT=COUNT+1

                       SET ^DIBT(+Y,1,Z)=""

 +7                IF COUNT

                       SET ^DIBT(+Y,"QR")=DT_U_COUNT

 +8                DO X

               End DoDot:1

               QUIT

 +9        MERGE @DIVROUT@(1)=^TMP("DIVR1",$JOB)

X          KILL ^TMP("DIVR1",$JOB)

 +1        QUIT

 +2       ;

INIT      ;Get header info and print first header

 +1        NEW %,%H,X,Y

 +2        KILL DIRUT

 +3       ;

 +4        SET %H=$HOROLOG

           DO YX^%DTC

 +5        SET DIVDAT=$PIECE(Y,"@")_"  "_$PIECE($PIECE(Y,"@",2),":",1,2)_"    PAGE "

 +6       ;

 +7        IF $DATA(^DIC(A,0))#2

               SET DIVFIL=$PIECE(^(0),U)_" FILE (#"_A_")"

 +8       IF '$TEST

               IF $DATA(^DD(A,0,"NM"))

                   SET DIVFIL=$ORDER(^("NM",""))_" SUB-FILE (#"_A_")"

 +9       IF '$TEST

               SET DIVFIL=""

 +10      ;

 +11       USE IO

 +12       IF IOST?1"C-".E

               WRITE @IOF

 +13       DO HDR^DIVR

 +14       QUIT

 +15      ;

DEVSEL    ;Prompt for device

 +1        Begin DoDot:1

 +2            NEW %ZIS,A,I,J,T,V,X,Y,Z

 +3            SET %ZIS=$EXTRACT("Q",$DATA(^%ZTSK)>0)

 +4            WRITE !

               DO ^%ZIS

           End DoDot:1

           IF $GET(POP)

               QUIT

 +5       ;

 +6        IF $DATA(IO("Q"))

               IF $DATA(^%ZTSK)

                   Begin DoDot:1

 +7                    SET ZTRTN="ENQUEUE^DIV"

 +8                    SET ZTDESC="Verify Fields Report for File #"_A

 +9                    NEW %,DIVA,DIVI,DIVJ,DIVT,DIVV,DIVY,DIVZ

 +10                   MERGE DIVA=A,DIVI=I,DIVJ=J,DIVT=T,DIVV=V,DIVY=Y,DIVZ=Z

 +11                   FOR %="DIU","DIUTIL","DIVMODE","DIVA","DIVI","DIVI(","DIVJ","DIVJ(","DIVV","DIVZ"

                           SET ZTSAVE(%)=""

 +12                   IF $GET(DIVMODE)'="A"

                           FOR %="DIVY","DIVY(","DR"

                               SET ZTSAVE(%)=""

 +13                   IF $GET(DIVMODE)="C"

                           FOR %="DA","DDC","DIFLD","DIVT"

                               SET ZTSAVE(%)=""

 +14                   DO ^%ZTLOAD

 +15                   IF $DATA(ZTSK)#2

                           WRITE !,"Report queued!",!,"Task number: "_$GET(ZTSK),!

 +16                  IF '$TEST

                           WRITE !,"Report canceled!",!

 +17                   KILL ZTSK

 +18                   SET IOP="HOME"

                       DO ^%ZIS

                   End DoDot:1

                   SET POP=1

 +19       QUIT

 +20      ;

ENQUEUE   ;Entry point for queued reports

 +1        MERGE A=DIVA,I=DIVI,J=DIVJ,T=DIVT,V=DIVV,Y=DIVY,Z=DIVZ

 +2        KILL DIVA,DIVI,DIVJ,DIVT,DIVV,DIVY,DIVZ

 +3        SET Q=""""

           SET S=";"

 +4       ;

 +5        DO INIT

 +6        IF $GET(DIVMODE)="A"

               DO FLDS

               DO Q^DIVR

               QUIT

 +7        IF $GET(DIVMODE)="C"

               DO ^DIVR

               QUIT

 +8        DO 1

 +9        QUIT

DIV.m