- DIVRE ;SFISC/MWE-REQ FLD(S) CHK ;2:52 PM 10 Jun 1997
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- B K ^UTILITY($J),DIBT S (DK,DIC)=DI,DIC(0)="EQM",DIK=0
- W !,"CHECK WHICH ENTRY: " R X:DTIME G QQ:U[X!'$T
- I X="ALL" D ALL G QQ:$D(DIRUT) I Y S DIROOT=DIU G D
- D ^DIC I Y<0 W:X?1."?" !?3,"You may type 'ALL' to select every entry in the file.",! G B
- R S DIK=DIK+1,^UTILITY($J,"DIN",+Y)=""
- S DIC(0)="AEQM",DIC("A")="ANOTHER ONE: " D ^DIC I Y>0 G R
- Q:'DIK!(X=U)
- D ;
- D S2^DIBT1 K DIRUT,DIROUT G QQ:$D(DTOUT)!($D(DUOUT))
- I X]"" G D:Y<0 S:Y>0 DIBT=+Y
- S DIC=DI
- S:$D(^%ZTSK) %ZIS="Q" D ^%ZIS G:POP QQ
- I $G(IO("Q"))=1 G TSK
- L I $E(IOST)="C" S DIFF=1
- S (DC,DA,N)=0 S:'$D(DIROOT) DIROOT="^UTILITY($J,""DIN""," F I=0:0 S DA=$O(@(DIROOT_DA_")")) Q:'DA W:IOST?1"C".E "." D START
- I N U IO S DC=0 D PH F N=1:1 Q:'$D(^UTILITY($J,"DIVRE",N)) S X=^(N) D P I IOST?1"C".E,$Y>(IOSL-4) W $C(7) R X:DTIME Q:X=U!'$T
- I 'N U IO D PH W !!,"NO REQUIRED FIELD IS MISSING"
- Q W:$E(IOST)'="C"&($Y) @IOF X $G(^%ZIS("C"))
- QQ K DIRUT,DTOUT,DUOUT,DIROUT,DK,C,D,I,J,N,F,S,G,P,L,X,Y,DI,DIK,DIC,DISD,DIREF,DIFLD,DC,DIROOT,DIFF,^UTILITY($J)
- Q
- P ;
- D:$Y>(IOSL-3) PH
- S %=$P(X,U),Y=$P(@(^DIC($P(%,";",2),0,"GL")_+%_",0)"),U,1),C=$P(^DD($P(%,";",2),.01,0),U,2) D Y^DIQ
- W !,+$P(X,U),?10,$E(Y,1,20),?35,$P(X,U,2),?50,$P(^DD($P(X,U,2),$P(X,U,3),0),U)
- Q:DUZ(0)'="@"
- I IOM>80 W ?85,$P(X,U,4) Q
- W !?35,$P(X,U,4) Q
- PH ;
- S DC=DC+1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W "Required-Field-Check File: ",DIC_" "_$O(^DD(DIC,0,"NM","")),?(IOM-25) S Y=DT D DD^%DT W ?(IOM-10),"PAGE ",DC
- W !,"Entry",?35,"DD-Number",$S((DUZ(0)="@")+(IOM'>80)=2:"/Path",1:""),?50,"Field" I DUZ(0)="@",IOM>80 W ?85,"Path"
- W ! F L=1:1:(IOM-2) W "-"
- Q
- CHECK ;
- I $P(^DD(DIC,DIFLD,0),U,2)'["R",'$D(DIKEYCHK) Q
- S G=$P(^(0),U,4),P=$P(G,";",2),G=$P(G,";") S:'P P=1
- I $D(@(DIREF_","""_G_""")")),$P(^(G),U,P)]"" Q
- N % S %=0 S N=N+1,^UTILITY($J,"DIVRE",N)=D(1)_";"_I(1)_U_DIC_U_DIFLD_DIREF S:$D(DIBT) %=%+1,^DIBT(DIBT,1,D(1))=""
- I %,$G(DIBT) S ^DIBT(DIBT,"QR")=DT_U_%
- Q
- START ;
- S L=1,DIC=$S('DIC:+$P(@(DIC_"0)"),U,2),1:DIC),DIREF=^DIC(DIC,0,"GL"),X="",U="^",DIREF=DIREF_DA
- M S J(L)=DIREF,I(L)=DIC,D(L)=DA K DIFLIST,DIKEYCHK
- S DIFLD=0 F I=0:0 S DIFLD=$O(^DD(DIC,"RQ",DIFLD)) Q:'DIFLD S F(L)=DIFLD,DIFLIST(DIFLD)="" D CHECK
- S DIKEYCHK=1,DIFLD=0 F S DIFLD=$O(^DD("KEY","F",DIC,DIFLD)) Q:'DIFLD I '$D(DIFLIST(DIFLD)) S F(L)=DIFLD D CHECK
- K DIFLIST,DIKEYCHK S F(L)=""
- S DISD=0 F I=0:0 S DISD=$O(^DD(DIC,"SB",DISD)) Q:'DISD S S(L)=DISD D NEW
- Q
- NEW ;
- S L=L+1
- S DINODE=$P($P(^DD(I(L-1),$O(^DD(I(L-1),"SB",DISD,"")),0),U,4),";")
- I DINODE="" S DINODE=0
- E I DINODE'=+$P(DINODE,"E") S DINODE=""""_DINODE_""""
- S DIC=DISD,DIREF=DIREF_","_DINODE_"," K DINODE
- S DA=0 F I=0:0 S DA=$O(@(DIREF_DA_")")) Q:'DA S DIREF(L)=DIREF,DIREF=DIREF_DA D M S DIREF=DIREF(L)
- S L=L-1,DIC=I(L),DIREF=J(L),DA=D(L),DIFLD=F(L),DISD=S(L)
- Q
- TSK ;
- S ZTRTN="L^DIVRE",ZTDESC="REQUIRED FIELD CHECK",ZTIO=ION_";"_IOST_";"_IOM
- F N="DIC","^UTILITY($J,","DIROOT" S ZTSAVE(N)=""
- D ^%ZTLOAD X $G(^%ZIS("C")) G QQ
- ;
- ALL S DIR(0)="Y",DIR("??")="^D H^DIVRE1"
- S DIR("A")="DO YOU MEAN ALL THE ENTRIES IN THE FILE"
- D ^DIR K DIR S X="ALL"
- Q
- DIVRE ;SFISC/MWE-REQ FLD(S) CHK ;2:52 PM 10 Jun 1997
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- B KILL ^UTILITY($JOB),DIBT
- SET (DK,DIC)=DI
- SET DIC(0)="EQM"
- SET DIK=0
- +1 WRITE !,"CHECK WHICH ENTRY: "
- READ X:DTIME
- IF U[X!'$TEST
- GOTO QQ
- +2 IF X="ALL"
- DO ALL
- IF $DATA(DIRUT)
- GOTO QQ
- IF Y
- SET DIROOT=DIU
- GOTO D
- +3 DO ^DIC
- IF Y<0
- IF X?1."?"
- WRITE !?3,"You may type 'ALL' to select every entry in the file.",!
- GOTO B
- R SET DIK=DIK+1
- SET ^UTILITY($JOB,"DIN",+Y)=""
- +1 SET DIC(0)="AEQM"
- SET DIC("A")="ANOTHER ONE: "
- DO ^DIC
- IF Y>0
- GOTO R
- +2 IF 'DIK!(X=U)
- QUIT
- D ;
- +1 DO S2^DIBT1
- KILL DIRUT,DIROUT
- IF $DATA(DTOUT)!($DATA(DUOUT))
- GOTO QQ
- +2 IF X]""
- IF Y<0
- GOTO D
- IF Y>0
- SET DIBT=+Y
- +3 SET DIC=DI
- +4 IF $DATA(^%ZTSK)
- SET %ZIS="Q"
- DO ^%ZIS
- IF POP
- GOTO QQ
- +5 IF $GET(IO("Q"))=1
- GOTO TSK
- L IF $EXTRACT(IOST)="C"
- SET DIFF=1
- +1 SET (DC,DA,N)=0
- IF '$DATA(DIROOT)
- SET DIROOT="^UTILITY($J,""DIN"","
- FOR I=0:0
- SET DA=$ORDER(@(DIROOT_DA_")"))
- IF 'DA
- QUIT
- IF IOST?1"C".E
- WRITE "."
- DO START
- +2 IF N
- USE IO
- SET DC=0
- DO PH
- FOR N=1:1
- IF '$DATA(^UTILITY($JOB,"DIVRE",N))
- QUIT
- SET X=^(N)
- DO P
- IF IOST?1"C".E
- IF $Y>(IOSL-4)
- WRITE $CHAR(7)
- READ X:DTIME
- IF X=U!'$TEST
- QUIT
- +3 IF 'N
- USE IO
- DO PH
- WRITE !!,"NO REQUIRED FIELD IS MISSING"
- Q IF $EXTRACT(IOST)'="C"&($Y)
- WRITE @IOF
- XECUTE $GET(^%ZIS("C"))
- QQ KILL DIRUT,DTOUT,DUOUT,DIROUT,DK,C,D,I,J,N,F,S,G,P,L,X,Y,DI,DIK,DIC,DISD,DIREF,DIFLD,DC,DIROOT,DIFF,^UTILITY($JOB)
- +1 QUIT
- P ;
- +1 IF $Y>(IOSL-3)
- DO PH
- +2 SET %=$PIECE(X,U)
- SET Y=$PIECE(@(^DIC($PIECE(%,";",2),0,"GL")_+%_",0)"),U,1)
- SET C=$PIECE(^DD($PIECE(%,";",2),.01,0),U,2)
- DO Y^DIQ
- +3 WRITE !,+$PIECE(X,U),?10,$EXTRACT(Y,1,20),?35,$PIECE(X,U,2),?50,$PIECE(^DD($PIECE(X,U,2),$PIECE(X,U,3),0),U)
- +4 IF DUZ(0)'="@"
- QUIT
- +5 IF IOM>80
- WRITE ?85,$PIECE(X,U,4)
- QUIT
- +6 WRITE !?35,$PIECE(X,U,4)
- QUIT
- PH ;
- +1 SET DC=DC+1
- IF $DATA(DIFF)&($Y)
- WRITE @IOF
- SET DIFF=1
- WRITE "Required-Field-Check File: ",DIC_" "_$ORDER(^DD(DIC,0,"NM","")),?(IOM-25)
- SET Y=DT
- DO DD^%DT
- WRITE ?(IOM-10),"PAGE ",DC
- +2 WRITE !,"Entry",?35,"DD-Number",$SELECT((DUZ(0)="@")+(IOM'>80)=2:"/Path",1:""),?50,"Field"
- IF DUZ(0)="@"
- IF IOM>80
- WRITE ?85,"Path"
- +3 WRITE !
- FOR L=1:1:(IOM-2)
- WRITE "-"
- +4 QUIT
- CHECK ;
- +1 IF $PIECE(^DD(DIC,DIFLD,0),U,2)'["R"
- IF '$DATA(DIKEYCHK)
- QUIT
- +2 SET G=$PIECE(^(0),U,4)
- SET P=$PIECE(G,";",2)
- SET G=$PIECE(G,";")
- IF 'P
- SET P=1
- +3 IF $DATA(@(DIREF_","""_G_""")"))
- IF $PIECE(^(G),U,P)]""
- QUIT
- +4 NEW %
- SET %=0
- SET N=N+1
- SET ^UTILITY($JOB,"DIVRE",N)=D(1)_";"_I(1)_U_DIC_U_DIFLD_DIREF
- IF $DATA(DIBT)
- SET %=%+1
- SET ^DIBT(DIBT,1,D(1))=""
- +5 IF %
- IF $GET(DIBT)
- SET ^DIBT(DIBT,"QR")=DT_U_%
- +6 QUIT
- START ;
- +1 SET L=1
- SET DIC=$SELECT('DIC:+$PIECE(@(DIC_"0)"),U,2),1:DIC)
- SET DIREF=^DIC(DIC,0,"GL")
- SET X=""
- SET U="^"
- SET DIREF=DIREF_DA
- M SET J(L)=DIREF
- SET I(L)=DIC
- SET D(L)=DA
- KILL DIFLIST,DIKEYCHK
- +1 SET DIFLD=0
- FOR I=0:0
- SET DIFLD=$ORDER(^DD(DIC,"RQ",DIFLD))
- IF 'DIFLD
- QUIT
- SET F(L)=DIFLD
- SET DIFLIST(DIFLD)=""
- DO CHECK
- +2 SET DIKEYCHK=1
- SET DIFLD=0
- FOR
- SET DIFLD=$ORDER(^DD("KEY","F",DIC,DIFLD))
- IF 'DIFLD
- QUIT
- IF '$DATA(DIFLIST(DIFLD))
- SET F(L)=DIFLD
- DO CHECK
- +3 KILL DIFLIST,DIKEYCHK
- SET F(L)=""
- +4 SET DISD=0
- FOR I=0:0
- SET DISD=$ORDER(^DD(DIC,"SB",DISD))
- IF 'DISD
- QUIT
- SET S(L)=DISD
- DO NEW
- +5 QUIT
- NEW ;
- +1 SET L=L+1
- +2 SET DINODE=$PIECE($PIECE(^DD(I(L-1),$ORDER(^DD(I(L-1),"SB",DISD,"")),0),U,4),";")
- +3 IF DINODE=""
- SET DINODE=0
- +4 IF '$TEST
- IF DINODE'=+$PIECE(DINODE,"E")
- SET DINODE=""""_DINODE_""""
- +5 SET DIC=DISD
- SET DIREF=DIREF_","_DINODE_","
- KILL DINODE
- +6 SET DA=0
- FOR I=0:0
- SET DA=$ORDER(@(DIREF_DA_")"))
- IF 'DA
- QUIT
- SET DIREF(L)=DIREF
- SET DIREF=DIREF_DA
- DO M
- SET DIREF=DIREF(L)
- +7 SET L=L-1
- SET DIC=I(L)
- SET DIREF=J(L)
- SET DA=D(L)
- SET DIFLD=F(L)
- SET DISD=S(L)
- +8 QUIT
- TSK ;
- +1 SET ZTRTN="L^DIVRE"
- SET ZTDESC="REQUIRED FIELD CHECK"
- SET ZTIO=ION_";"_IOST_";"_IOM
- +2 FOR N="DIC","^UTILITY($J,","DIROOT"
- SET ZTSAVE(N)=""
- +3 DO ^%ZTLOAD
- XECUTE $GET(^%ZIS("C"))
- GOTO QQ
- +4 ;
- ALL SET DIR(0)="Y"
- SET DIR("??")="^D H^DIVRE1"
- +1 SET DIR("A")="DO YOU MEAN ALL THE ENTRIES IN THE FILE"
- +2 DO ^DIR
- KILL DIR
- SET X="ALL"
- +3 QUIT
