DDPA2.m

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 ---DDPA2   1524     printed  Apr 09, 2024@21:45:57                                                                                                                                                                                                       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