Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIVR

DIVR.m

Go to the documentation of this file. 
  1. DIVR ;SFISC/GFT-VERIFY FLDS ;8:43 AM  1 Jul 1999 [ 04/02/2003   8:25 AM ]
  1.  ;;22.0;VA FileMan;**1001**;APR 1, 2003
  1.  ;;22.0;VA FileMan;**7**;Mar 30, 1999
  1.  ;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/ASDST/GTH 04-04-01
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  I $D(DIVFIL)[0 N DIVDAT,DIVFIL,DIVMODE,DIVPG,POP D  G:$G(POP) Q^DIV
  1.  . S DIVMODE="C"
  1.  . D DEVSEL^DIV Q:$G(POP)
  1.  . D INIT^DIV
  1.  S W="W !,""ENTRY#"_$S(V:"'S",1:"")_""",?10,"""_$P(^DD(A,.01,0),U)_""",?40,""ERROR"""
  1.  D LF Q:$D(DIRUT)  S T=$E(T) S:"PS"[T&($D(DIVZ)[0) DIVZ=Z
  1.  K DIVREQK,DIVTYPE,DIVTMP
  1.  S DIVREQK=$D(^DD("KEY","F",A,DA))>9
  1.  I $D(^DD("IX","F",A,DA)) D
  1.  . S DIVTYPE=T,T="INDEX",DIVROOT=$$FROOTDA^DIKCU(A)
  1.  . D LOADVER^DIVC(A,DA,"DIVTMP")
  1.  K DG
  1.  F %=0:0 S %=$O(^DD(A,DA,1,%)) Q:%'>0  I $D(^(%,1)),$P(^(0),U,2,9)?1.A,^(2)?1"K ^".E1")",^(1)?1"S ^".E S DG(%)="I $D("_$E(^(2),3,99)_"),"_$E(^(1),3,99)
  1.  I T'="INDEX",'$D(^(+$O(^DD(A,DA,1,0)),1)) G E
  1.  I T'="INDEX",'$D(DG) W $C(7)_"(CANNOT CHECK"
  1.  E  W "(CHECKING"
  1.  W " CROSS-REFERENCE)" D LF I $D(DIRUT) Q:$D(DQI)  G Q
  1.  I $D(DG) D
  1.  . I T="INDEX" S E=DIVTYPE,DIVTYPE="IX"
  1.  . E  S E=T,T="IX"
  1. E S Y=$F(DDC,"%DT=""E") S:Y DDC=$E(DDC,1,Y-2)_$E(DDC,Y,999)
  1.  I DR["*" S DDC="Q" I $D(^DD(A,DA,12.1)) X ^(12.1) I $D(DIC("S")) S DDC(1)=DIC("S"),DDC="X DDC(1) E  K X"
  1.  D 0 S X=$P(Y(0),U,4),Y=$P(X,S,2),X=$P(X,S)
  1.  I +X'=X S X=Q_X_Q I Y="" S DE=DE_"S X=DA D R" G XEC
  1.  S M="S X=$S($D(^(DA,"_X_")):$"_$S(Y:"P(^("_X_"),U,"_Y,1:"E(^("_X_"),"_$E(Y,2,9))_"),1:"""") D R"
  1.  I $L(M)+$L(DE)>250 S DE=DE_"X DE(1)",DE(1)=M
  1.  E  S DE=DE_M
  1. XEC K DIC,M,Y X DE Q:$D(DQI)
  1.  W:'$D(M) $C(7),!,"NO PROBLEMS"
  1. Q S M=$O(^UTILITY("DIVR",$J,0)),E=$O(^(M)),DK=J(0)
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  ;----- BEGIN IHS MODIFICATION
  1.  ;THE LINE BELOW IS COMMENTED OUT AND REPLACED BY A NEW LINE TO
  1.  ;PREVENT A <LINER> ERROR IN MSM AS LINE TAG 0 DOES NOT EXIST
  1.  ;ORIGINAL MODIFICATION BY IHS/ASDST/GTH 04-04-01
  1.  ;E  I $T(+0^%ZISC)]"" D
  1.  E  I $T(^%ZISC)]"" D
  1.  . ;----- END IHS MODIFICATION
  1.  . D ^%ZISC
  1.  E  X $G(^%ZIS("C"))
  1.  G:'E!$D(DIRUT)!$D(ZTQUEUED) QX K DIBT,DISV D
  1.  . N C,D,I,J,L,O,Q,S,D0,DDA,DICL,DIFLD,DIU0
  1.  . D S2^DIBT1 Q
  1.  S DDC=0 I '$D(DIRUT) G Q:Y<0 F E=0:0 S E=$O(^UTILITY("DIVR",$J,E)) Q:E=""  S DDC=DDC+1,^DIBT(+Y,1,E)=""
  1.  S:DDC>0 ^DIBT(+Y,"QR")=DT_U_DDC
  1. QX K DIVINDEX,DIVKEY,DIVREQK,DIVROOT,DIVTMP,DIVTYPE
  1.  K ^UTILITY("DIVR",$J),DIRUT,DIROUT,DTOUT,DUOUT,DQI,DK,DA,DG,DQ,DE,T,P,E,M,DR,W,DDC,DIVZ Q
  1.  ;
  1. R Q:$D(DIRUT)
  1.  I X?." " Q:DR'["R"&'DIVREQK  D  G X
  1.  . I X="" S M="Missing"_$S(DIVREQK:" key value",1:"")
  1.  . E  S M="Equals only 1 or more spaces"
  1.  G @T
  1.  ;
  1. P I @("$D(^"_DIVZ_"X,0))") S Y=X G F
  1.  S M="No '"_X_"' in pointed-to File" G X
  1.  ;
  1. S S Y=X X DDC I '$D(X) S M=Q_Y_Q_" fails screen" G X
  1.  Q:S_DIVZ[(S_X_":")  S M=Q_X_Q_" not in Set" G X
  1.  ;
  1. D S Y=X,X=$E(Y,1,3)+1700,%=$E(Y,6,7) S:% X=%_"-"_X S:$E(Y,4,5) X=+$E(Y,4,5)_"-"_X
  1.  S:Y["." X=X_"@"_$E(Y_"00",9,10)_":"_$E(Y_"0000",11,12)_$S($E(Y,13,14):":"_$E(Y_"0",13,14),1:"")
  1. N ;
  1. K ;
  1. F S DQ=X I X'?.ANP S M="Non-printing character" G X
  1.  X DDC Q:$D(X)  S M=Q_DQ_Q_" fails Input Transform"
  1. X I $O(^UTILITY("DIVR",$J,0))="" X W
  1.  S X=$S(V:DA(V),1:DA),^UTILITY("DIVR",$J,X)=""
  1.  S X=V I @(I(0)_"0)")
  1. DA I 'X D  Q
  1.  . D LF Q:$D(DIRUT)
  1.  . W DA,?10,$S($D(^(DA,0)):$P(^(0),U),1:DA),?40,$E(M,1,40)
  1.  . D:V LF
  1.  D LF Q:$D(DIRUT)  W DA(X),?10,$P(^(DA(X),0),U) S X=X-1,@("Y=$D(^("_I(V-X)_",0))") G DA
  1.  ;
  1. 0 ;
  1.  S Y=I(0),DE="",X=V
  1. L S DA="DA" S:X DA=DA_"("_X_")" S Y=Y_DA,DE=DE_"F "_DA_"=0:0 ",%="S "_DA_"=$O("_Y_"))" I V>2 S DE(X+X)=%,DE=DE_"X DE("_(X+X)_")"
  1.  E  S DE=DE_%
  1.  S DE=DE_" Q:"_DA_"'>0  S D"_(V-X)_"="_DA_" "
  1.  ;I X=1,DIFLD=.01 S DE=DE_"X P:$D(^(DA(1),"_I(V)_",0)) ",P="S $P(^(0),U,2)="""_$P(^DD(J(V-1),P,0),U,2)_Q
  1.  S X=X-1 Q:X<0  S Y=Y_","_I(V-X)_"," G L
  1.  ;
  1. IX F %=0:0 S %=$O(DG(%)) Q:+%'>0  X DG(%) I '$T S M=Q_X_Q_" not properly Cross-referenced" G X
  1.  G @E
  1.  ;
  1. V I $P(X,S,2)'?1A.AN1"(".ANP,$P(X,S,2)'?1"%".AN1"(".ANP S M=Q_X_Q_" has the wrong format" G X
  1.  S M=$S($D(@(U_$P(X,S,2)_"0)")):^(0),1:"")
  1.  I '$D(^DD(A,DIFLD,"V","B",+$P(M,U,2))) S M=$P(M,U)_" FILE not in the DD" G X
  1.  I '$D(@(U_$P(X,S,2)_+X_",0)")) S M=U_$P(X,S,2)_+X_",0) does not exist" G X
  1.  G F
  1.  ;
  1. INDEX ;Check new indexes
  1.  ;
  1.  ;Set DIVINDEX(indexName,index#) = "" for indexes aren't set
  1.  ;Set DIVKEY(file#,keyName,uiNumber) = "null" : if key field is null
  1.  ;                                     "uniq" : if key is not unique
  1.  K DIVKEY,DIINDEX
  1.  D VER^DIVC(A,DIVROOT,.DA,"DIVTMP",.DIVINDEX,.DIVKEY)
  1.  ;
  1.  ;If some indexes aren't set properly, print index info
  1.  I $D(DIVINDEX) D  K DIVINDEX Q:$D(DIRUT)
  1.  . N DIVNAME,DIVNUM
  1.  . S DIVNAME="" F  S DIVNAME=$O(DIVINDEX(DIVNAME)) Q:DIVNAME=""  D  Q:$D(DIRUT)
  1.  .. S DIVNUM=0 F  S DIVNUM=$O(DIVINDEX(DIVNAME,DIVNUM)) Q:'DIVNUM  D  Q:$D(DIRUT)
  1.  ... S M=Q_X_Q_": "_DIVNAME_" index (#"_DIVNUM_") not properly set"
  1.  ... D IER
  1.  ;
  1.  ;If keys integrity is violated, print key info
  1.  I $D(DIVKEY) D  K DIVKEY Q:$D(DIRUT)
  1.  . N DIVFILE,DIVKNM,DIVPROB,DIVXRNM
  1.  . S DIVFILE="" F  S DIVFILE=$O(DIVKEY(DIVFILE)) Q:DIVFILE=""  D  Q:$D(DIRUT)
  1.  .. S DIVKNM="" F  S DIVKNM=$O(DIVKEY(DIVFILE,DIVKNM)) Q:DIVKNM=""  D  Q:$D(DIRUT)
  1.  ... S DIVXRNM="" F  S DIVXRNM=$O(DIVKEY(DIVFILE,DIVKNM,DIVXRNM)) Q:DIVXRNM=""  D  Q:$D(DIRUT)
  1.  .... S DIVPROB=DIVKEY(DIVFILE,DIVKNM,DIVXRNM)
  1.  .... S M=Q_X_Q_": "_$S(DIVPROB="null":"Key values are missing.",1:"Key is not unique.")
  1.  .... S M=M_" (File #"_DIVFILE_", Key "_DIVKNM_", Index "_DIVXRNM_")"
  1.  .... D IER
  1.  ;
  1.  ;Continue with checking traditional xrefs (if any) and data type
  1.  G @DIVTYPE
  1.  ;
  1. IER ;Print info about invalid indexes. (Modeled after DA subroutine above)
  1.  N DIVTXT,DIVI,X
  1.  ;
  1.  ;Wrap message M to within 40 columns
  1.  S DIVTXT(0)=M D WRAP^DIKCU2(.DIVTXT,40)
  1.  ;
  1.  ;If nothing was written yet, write column headers
  1.  I $O(^UTILITY("DIVR",$J,0))="" X W
  1.  ;
  1.  ;Set ^UTILITY("DIVR",$J,topIen)="", X = level#, naked = top level root
  1.  S X=$S(V:DA(V),1:DA),^UTILITY("DIVR",$J,X)=""
  1.  S X=V I @(I(0)_"0)")
  1.  ;
  1. IER1 ;If top level, write record info and message
  1.  I 'X D  Q
  1.  . D LF Q:$D(DIRUT)  W DA,?10,$S($D(^(DA,0)):$P(^(0),U),1:DA)
  1.  . F DIVI=0:1 Q:$D(DIVTXT(DIVI))[0  D  Q:$D(DIRUT)
  1.  .. I DIVI D LF Q:$D(DIRUT)
  1.  .. W ?40,DIVTXT(DIVI)
  1.  . D:V LF
  1.  ;
  1.  ;Else write subrecord info, decrement level, set naked = ^naked(node,0)
  1.  D LF Q:$D(DIRUT)
  1.  W DA(X),?10,$P(^(DA(X),0),U) S X=X-1,@("Y=$D(^("_I(V-X)_",0))")
  1.  G IER1
  1.  ;
  1. LF ;Issue a line feed or EOP read
  1.  I $Y+3<IOSL W ! Q
  1.  ;
  1.  N DINAKED S DINAKED=$$LGR^%ZOSV
  1.  I IOST?1"C-".E D
  1.  . N DIR,X,Y
  1.  . S DIR(0)="E" W ! D ^DIR
  1.  ;
  1.  I '$D(DIRUT) D
  1.  . I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1
  1.  . E  W @IOF D HDR
  1.  S:DINAKED]"" DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED))
  1.  Q
  1.  ;
  1. HDR ;Print header
  1.  N DIVTAB
  1.  S DIVPG=$G(DIVPG)+1
  1.  W "VERIFY FIELDS REPORT"
  1.  ;
  1.  S DIVTAB=IOM-1-$L(DIVFIL)-$L(DIVDAT)-$L(DIVPG)
  1.  I DIVTAB>1 W !,DIVFIL_$J("",DIVTAB)_DIVDAT_DIVPG
  1.  E  W !,DIVFIL,!,$J("",IOM-1-$L(DIVDAT)-$L(DIVPG))_DIVDAT_DIVPG
  1.  W !,$TR($J("",IOM-1)," ","-"),!
  1.  Q