DITMU4 ;SFISC/EDE(OHPRD)-FIX ALL "PT" NODES ;Jan 05, 2015
;;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.
;
; This routine fixes all "PT" nodes for files 1 through the
; highest file number in the current UCI.
;
START ;
W:'$D(DITMU4("NOTALK")) !!,"This routine insures the ""PT"" node of each FileMan file is correct.",!
W:'$D(DITMU4("NOTALK")) !!,"Now checking false positives.",!
S U="^"
S DITMU4FI=.99999999 F DITMU4L=0:0 S DITMU4FI=$O(^DD(DITMU4FI)) Q:DITMU4FI'=+DITMU4FI I $D(^DD(DITMU4FI,0,"PT")) W:'$D(DITMU4("NOTALK")) !,DITMU4FI D FPOS
W:'$D(DITMU4("NOTALK")) !!,"Now checking false negatives.",!
D FNEG
K DITMU4FI,DITMU4L
W:'$D(DITMU4("NOTALK")) !!,"DONE",!
Q
;
FPOS ; CHECK FOR FALSE POSITIVES
S DITMU4PF="" F DITMU4L=0:0 S DITMU4PF=$O(^DD(DITMU4FI,0,"PT",DITMU4PF)) Q:DITMU4PF="" S DITMU4PD="" F DITMU4L=0:0 S DITMU4PD=$O(^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)) Q:DITMU4PD="" D CHKIT
K DITMU4PF,DITMU4PD,DITMU4X
Q
;
CHKIT ;
W:'$D(DITMU4("NOTALK")) "."
I '$D(^DD(DITMU4PF)) W:'$D(DITMU4("NOTALK")) "|" K ^DD(DITMU4FI,0,"PT",DITMU4PF) Q
I '$D(^DD(DITMU4PF,DITMU4PD,0)) W:'$D(DITMU4("NOTALK")) "|" K ^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD) Q
S DITMU4X=$P(^DD(DITMU4PF,DITMU4PD,0),U,2)
I DITMU4X["P",DITMU4X[DITMU4FI Q
I DITMU4X["V",$D(^DD(DITMU4PF,DITMU4PD,"V","B",DITMU4FI)) Q
W:'$D(DITMU4("NOTALK")) "|" K ^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)
Q
;
FNEG ; CHECK FOR FALSE NEGATIVES
S DITMU4FI=.99999999 F DITMU4L=0:0 S DITMU4FI=$O(^DD(DITMU4FI)) Q:DITMU4FI'=+DITMU4FI W:'$D(DITMU4("NOTALK")) !,DITMU4FI S DITMU4FD=0 F DITMU4L=0:0 S DITMU4FD=$O(^DD(DITMU4FI,DITMU4FD)) Q:DITMU4FD'=+DITMU4FD D:$D(^(DITMU4FD,0))#2 PTRCHK
K DITMU4FI,DITMU4FD,DITMU4X,DITMU4I
Q
;
PTRCHK ;
S DITMU4X=$P(^(0),U,2)
I DITMU4X["V" D PTRCHK2 Q
Q:DITMU4X'["P"
F DITMU4I=1:1:$L(DITMU4X)+1 Q:$E(DITMU4X,DITMU4I)?1N
Q:DITMU4I>$L(DITMU4X)
S DITMU4X=$E(DITMU4X,DITMU4I,999),DITMU4X=+DITMU4X
Q:'DITMU4X
Q:DITMU4X<1 ;*** DOES NOT MESS WITH FILE NUMBERS < 1 ***
W:'$D(DITMU4("NOTALK")) "."
Q:'$D(^DIC(DITMU4X))
Q:'$D(^DD(DITMU4X,0))
I '$D(^DD(DITMU4X,0,"PT",DITMU4FI,DITMU4FD)) W "|" S ^(DITMU4FD)=""
Q
;
PTRCHK2 ; VARIABLE POINTER CHECK
S DITMU4X="" F DITMU4L=0:0 S DITMU4X=$O(^DD(DITMU4FI,DITMU4FD,"V","B",DITMU4X)) Q:DITMU4X="" I '$D(^DD(DITMU4X,0,"PT",DITMU4FI,DITMU4FD)) W:'$D(DITMU4("NOTALK")) "|" S ^(DITMU4FD)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITMU4 2663 printed Apr 09, 2024@21:51:08 Page 2
DITMU4 ;SFISC/EDE(OHPRD)-FIX ALL "PT" NODES ;Jan 05, 2015
+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 ;
+7 ; This routine fixes all "PT" nodes for files 1 through the
+8 ; highest file number in the current UCI.
+9 ;
START ;
+1 if '$DATA(DITMU4("NOTALK"))
WRITE !!,"This routine insures the ""PT"" node of each FileMan file is correct.",!
+2 if '$DATA(DITMU4("NOTALK"))
WRITE !!,"Now checking false positives.",!
+3 SET U="^"
+4 SET DITMU4FI=.99999999
FOR DITMU4L=0:0
SET DITMU4FI=$ORDER(^DD(DITMU4FI))
if DITMU4FI'=+DITMU4FI
QUIT
IF $DATA(^DD(DITMU4FI,0,"PT"))
if '$DATA(DITMU4("NOTALK"))
WRITE !,DITMU4FI
DO FPOS
+5 if '$DATA(DITMU4("NOTALK"))
WRITE !!,"Now checking false negatives.",!
+6 DO FNEG
+7 KILL DITMU4FI,DITMU4L
+8 if '$DATA(DITMU4("NOTALK"))
WRITE !!,"DONE",!
+9 QUIT
+10 ;
FPOS ; CHECK FOR FALSE POSITIVES
+1 SET DITMU4PF=""
FOR DITMU4L=0:0
SET DITMU4PF=$ORDER(^DD(DITMU4FI,0,"PT",DITMU4PF))
if DITMU4PF=""
QUIT
SET DITMU4PD=""
FOR DITMU4L=0:0
SET DITMU4PD=$ORDER(^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD))
if DITMU4PD=""
QUIT
DO CHKIT
+2 KILL DITMU4PF,DITMU4PD,DITMU4X
+3 QUIT
+4 ;
CHKIT ;
+1 if '$DATA(DITMU4("NOTALK"))
WRITE "."
+2 IF '$DATA(^DD(DITMU4PF))
if '$DATA(DITMU4("NOTALK"))
WRITE "|"
KILL ^DD(DITMU4FI,0,"PT",DITMU4PF)
QUIT
+3 IF '$DATA(^DD(DITMU4PF,DITMU4PD,0))
if '$DATA(DITMU4("NOTALK"))
WRITE "|"
KILL ^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)
QUIT
+4 SET DITMU4X=$PIECE(^DD(DITMU4PF,DITMU4PD,0),U,2)
+5 IF DITMU4X["P"
IF DITMU4X[DITMU4FI
QUIT
+6 IF DITMU4X["V"
IF $DATA(^DD(DITMU4PF,DITMU4PD,"V","B",DITMU4FI))
QUIT
+7 if '$DATA(DITMU4("NOTALK"))
WRITE "|"
KILL ^DD(DITMU4FI,0,"PT",DITMU4PF,DITMU4PD)
+8 QUIT
+9 ;
FNEG ; CHECK FOR FALSE NEGATIVES
+1 SET DITMU4FI=.99999999
FOR DITMU4L=0:0
SET DITMU4FI=$ORDER(^DD(DITMU4FI))
if DITMU4FI'=+DITMU4FI
QUIT
if '$DATA(DITMU4("NOTALK"))
WRITE !,DITMU4FI
SET DITMU4FD=0
FOR DITMU4L=0:0
SET DITMU4FD=$ORDER(^DD(DITMU4FI,DITMU4FD))
if DITMU4FD'=+DITMU4FD
QUIT
if $DATA(^(DITMU4FD,0))#2
DO PTRCHK
+2 KILL DITMU4FI,DITMU4FD,DITMU4X,DITMU4I
+3 QUIT
+4 ;
PTRCHK ;
+1 SET DITMU4X=$PIECE(^(0),U,2)
+2 IF DITMU4X["V"
DO PTRCHK2
QUIT
+3 if DITMU4X'["P"
QUIT
+4 FOR DITMU4I=1:1:$LENGTH(DITMU4X)+1
if $EXTRACT(DITMU4X,DITMU4I)?1N
QUIT
+5 if DITMU4I>$LENGTH(DITMU4X)
QUIT
+6 SET DITMU4X=$EXTRACT(DITMU4X,DITMU4I,999)
SET DITMU4X=+DITMU4X
+7 if 'DITMU4X
QUIT
+8 ;*** DOES NOT MESS WITH FILE NUMBERS < 1 ***
if DITMU4X<1
QUIT
+9 if '$DATA(DITMU4("NOTALK"))
WRITE "."
+10 if '$DATA(^DIC(DITMU4X))
QUIT
+11 if '$DATA(^DD(DITMU4X,0))
QUIT
+12 IF '$DATA(^DD(DITMU4X,0,"PT",DITMU4FI,DITMU4FD))
WRITE "|"
SET ^(DITMU4FD)=""
+13 QUIT
+14 ;
PTRCHK2 ; VARIABLE POINTER CHECK
+1 SET DITMU4X=""
FOR DITMU4L=0:0
SET DITMU4X=$ORDER(^DD(DITMU4FI,DITMU4FD,"V","B",DITMU4X))
if DITMU4X=""
QUIT
IF '$DATA(^DD(DITMU4X,0,"PT",DITMU4FI,DITMU4FD))
if '$DATA(DITMU4("NOTALK"))
WRITE "|"
SET ^(DITMU4FD)=""
+2 QUIT
