DDPA2 ;SFISC/TKW FIND NON-CANONIC SORT RANGES WITH NO ASK NODE ;8/8/95 10:46
V ;;22.0;VA FileMan;;Mar 30, 1999;Build 1
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; This routine will find any sort templates that have a sort field
; with a range that is FROM or TO a non-canonic number, has no
; ASK node, and that has
; had an extra space inserted by FM21 prior to patch DI*21*9.
N I,J,X,Y,DIR,DIERR,DTOUT,DIRUT,DIROUT,DUOUT
W !!,"This routine will report any sort templates that have been corrupted due to",!,"a bug in FM21 that has been repaired by patch DI*21*9.",!!
W "If any templates are reported here, you can repair them by editing the template,",!,"without changing any of the sort fields.",!
S DIR("?",1)="This routine will report any sort templates that may have been corrupted.",DIR("?",2)="If none show on the report, it means that none of the templates on your system"
S DIR("?")="needed to be edited."
S DIR(0)="Y",DIR("A")="Report corrupted sort templates",DIR("B")="Yes" D ^DIR K DIR Q:Y'=1
W !!,"Searching Sort Template file...please wait",!!,"Report of templates that need to be repaired",!!
F I=0:0 S I=$O(^DIBT(I)) Q:'I S X=$P($G(^(I,0)),U) D
. S DIERR=0 F J=0:0 Q:DIERR=1 S J=$O(^DIBT(I,2,J)) Q:'J I $P($G(^(J,0)),U,10)=4,'$G(^("ASK")),$G(^("SRTTXT"))]"" D
.. S Y=$P($G(^DIBT(I,2,J,"F")),U,2) I Y?1." "1.E S DIERR=1 Q
.. S Y=$P($G(^DIBT(I,2,J,"T")),U,2) I Y?1." "1.E S DIERR=1 Q
.. Q
. I DIERR=1 W "No. "_I_" Name: "_X,!
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDPA2 1524 printed Sep 23, 2025@20:18:56 Page 2
DDPA2 ;SFISC/TKW FIND NON-CANONIC SORT RANGES WITH NO ASK NODE ;8/8/95 10:46
V ;;22.0;VA FileMan;;Mar 30, 1999;Build 1
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; This routine will find any sort templates that have a sort field
+1 ; with a range that is FROM or TO a non-canonic number, has no
+2 ; ASK node, and that has
+3 ; had an extra space inserted by FM21 prior to patch DI*21*9.
+4 NEW I,J,X,Y,DIR,DIERR,DTOUT,DIRUT,DIROUT,DUOUT
+5 WRITE !!,"This routine will report any sort templates that have been corrupted due to",!,"a bug in FM21 that has been repaired by patch DI*21*9.",!!
+6 WRITE "If any templates are reported here, you can repair them by editing the template,",!,"without changing any of the sort fields.",!
+7 SET DIR("?",1)="This routine will report any sort templates that may have been corrupted."
SET DIR("?",2)="If none show on the report, it means that none of the templates on your system"
+8 SET DIR("?")="needed to be edited."
+9 SET DIR(0)="Y"
SET DIR("A")="Report corrupted sort templates"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if Y'=1
QUIT
+10 WRITE !!,"Searching Sort Template file...please wait",!!,"Report of templates that need to be repaired",!!
+11 FOR I=0:0
SET I=$ORDER(^DIBT(I))
if 'I
QUIT
SET X=$PIECE($GET(^(I,0)),U)
Begin DoDot:1
+12 SET DIERR=0
FOR J=0:0
if DIERR=1
QUIT
SET J=$ORDER(^DIBT(I,2,J))
if 'J
QUIT
IF $PIECE($GET(^(J,0)),U,10)=4
IF '$GET(^("ASK"))
IF $GET(^("SRTTXT"))]""
Begin DoDot:2
+13 SET Y=$PIECE($GET(^DIBT(I,2,J,"F")),U,2)
IF Y?1." "1.E
SET DIERR=1
QUIT
+14 SET Y=$PIECE($GET(^DIBT(I,2,J,"T")),U,2)
IF Y?1." "1.E
SET DIERR=1
QUIT
+15 QUIT
End DoDot:2
+16 IF DIERR=1
WRITE "No. "_I_" Name: "_X,!
+17 QUIT
End DoDot:1
+18 QUIT
