DIVRE ;SFISC/MWE-REQ FLD(S) CHK ;06:27 PM 7 Dec 1999
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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")=$$EZBLD^DIALOG(8199)_" " D ^DIC I Y>0 G R ;**CCO/NI 'ANOTHER ONE:'
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIVRE 3507 printed Apr 09, 2024@21:52:42 Page 2
DIVRE ;SFISC/MWE-REQ FLD(S) CHK ;06:27 PM 7 Dec 1999
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
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 ;**CCO/NI 'ANOTHER ONE:'
SET DIC(0)="AEQM"
SET DIC("A")=$$EZBLD^DIALOG(8199)_" "
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
