DIV ;SFISC/GFT - VERIFY FLDS ;5DEC2016
;;22.2;VA FileMan;**5**;Jan 05, 2016;Build 28
;;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.
;;GFT;**7,1003,1004,1015,1045,1057**
;
N DIUTIL,DIVDAT,DIVFIL,DIVMODE,DIVPG,POP S DIUTIL="VERIFY FIELDS"
K J
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)="QEZ",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,ALLFLDS(A) 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:+I(V)'=I(V) I(V)=""""_I(V)_"""" G DIC
D DEVSEL G:$G(POP) Q D INIT
D EN^DIVR(A,+Y)
Q K DIR,DIRUT,N,P
Q
;
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"
Q
;
;
;
ALLPOINT ;
N A,DIRUT D DEVSEL Q:$G(POP)
F A=1.9:0 S A=$O(^DIC(A)) Q:'A D INIT,ALLFLDS(A,"PV") Q:$D(DIRUT)
Q
;
ALLFLDS(A,DIVRTYPE) 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 Q:$P(^DD(+DR,.01,0),U,2)["W" D NEXTLVL Q
.I $G(DIVRTYPE)]"",$TR(DR,DIVRTYPE)=DR Q
.I DR["C" Q
.I $Y+6>IOSL S $Y=IOSL D LF^DIVR
.W !!!,"--",A,",",Y D EN^DIVR(A,Y,1) Q
Q
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 ALLFLDS(A,$G(DIVRTYPE))
Q
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."
Q
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)
Q
;
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
Q
;
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
Q
;
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 ALLFLDS(A),Q^DIVR Q
I $G(DIVMODE)="C" D EN^DIVR(A,DA) Q
D EN^DIVR(A,+Y)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIV 4122 printed Dec 13, 2024@02:54:44 Page 2
DIV ;SFISC/GFT - VERIFY FLDS ;5DEC2016
+1 ;;22.2;VA FileMan;**5**;Jan 05, 2016;Build 28
+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 ;;GFT;**7,1003,1004,1015,1045,1057**
+7 ;
+8 NEW DIUTIL,DIVDAT,DIVFIL,DIVMODE,DIVPG,POP
SET DIUTIL="VERIFY FIELDS"
+9 KILL J
+10 SET V=0
SET P=0
SET I(0)=DIU
SET @("(A,J(0))=+$P("_DIU_"0),U,2)")
+11 IF $ORDER(^(0))'>0
WRITE $CHAR(7)," NO ENTRIES ON FILE!"
QUIT
DIC SET DIC="^DD("_A_","
SET DIC(0)="QEZ"
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 ALLFLDS(A)
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),";")
if +I(V)'=I(V)
SET I(V)=""""_I(V)_""""
GOTO DIC
+7 DO DEVSEL
if $GET(POP)
GOTO Q
DO INIT
+8 DO EN^DIVR(A,+Y)
Q KILL DIR,DIRUT,N,P
+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 ;
+5 ;
+6 ;
ALLPOINT ;
+1 NEW A,DIRUT
DO DEVSEL
if $GET(POP)
QUIT
+2 FOR A=1.9:0
SET A=$ORDER(^DIC(A))
if 'A
QUIT
DO INIT
DO ALLFLDS(A,"PV")
if $DATA(DIRUT)
QUIT
+3 QUIT
+4 ;
ALLFLDS(A,DIVRTYPE) 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
DO NEXTLVL
QUIT
+2 IF $GET(DIVRTYPE)]""
IF $TRANSLATE(DR,DIVRTYPE)=DR
QUIT
+3 IF DR["C"
QUIT
+4 IF $Y+6>IOSL
SET $Y=IOSL
DO LF^DIVR
+5 WRITE !!!,"--",A,",",Y
DO EN^DIVR(A,Y,1)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+6 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 ALLFLDS(A,$GET(DIVRTYPE))
+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 ALLFLDS(A)
DO Q^DIVR
QUIT
+7 IF $GET(DIVMODE)="C"
DO EN^DIVR(A,DA)
QUIT
+8 DO EN^DIVR(A,+Y)
+9 QUIT
