Routine: DDSSTK

DDSSTK ;SFISC/MKO-STACK CONTEXT, GO TO A NEW PAGE ;08:23 AM  1 Nov 1994

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 N DDO

 N DDSBK,DDSDN,DDSFLD,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP

 I DDSSTACK?1"`".E D

 . S DDSSTACK=+$E(DDSSTACK,2,999)

 E  I DDSSTACK=+$P(DDSSTACK,"E") D

 . S DDSSTACK=+$O(^DIST(.403,+DDS,40,"B",DDSSTACK,""))

 E  D

 . S DDSSTACK=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(DDSSTACK),""))

 I 'DDSSTACK!($D(^DIST(.403,+DDS,40,+$G(DDSSTACK),0))[0) D  Q

 . K DDSSTACK,DDSBR

 N DDSDAORG,DDSDLORG,DDSFLORG,DDSPG

 N:'$P(^DIST(.403,+DDS,40,+$G(DDSSTACK),0),U,6) DDSSC

 S DDSPG=DDSSTACK

 K DDSSTACK,DDSBR

 S DDSDLORG=DDSDL,DDSDAORG=DA

 F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI)

 K DDSI

 S DDSSTK=1

 D PROC^DDS

UPCASE(X) ;

 ;Return X in uppercase

 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

DDSSTK    ;SFISC/MKO-STACK CONTEXT, GO TO A NEW PAGE ;08:23 AM  1 Nov 1994

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        NEW DDO

 +4        NEW DDSBK,DDSDN,DDSFLD,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP

 +5       ;

 +6        IF DDSSTACK?1"`".E

               Begin DoDot:1

 +7                SET DDSSTACK=+$EXTRACT(DDSSTACK,2,999)

               End DoDot:1

 +8       IF '$TEST

               IF DDSSTACK=+$PIECE(DDSSTACK,"E")

                   Begin DoDot:1

 +9                    SET DDSSTACK=+$ORDER(^DIST(.403,+DDS,40,"B",DDSSTACK,""))

                   End DoDot:1

 +10      IF '$TEST

               Begin DoDot:1

 +11               SET DDSSTACK=$ORDER(^DIST(.403,+DDS,40,"C",$$UPCASE(DDSSTACK),""))

               End DoDot:1

 +12      ;

 +13       IF 'DDSSTACK!($DATA(^DIST(.403,+DDS,40,+$GET(DDSSTACK),0))[0)

               Begin DoDot:1

 +14               KILL DDSSTACK,DDSBR

               End DoDot:1

               QUIT

 +15      ;

 +16       NEW DDSDAORG,DDSDLORG,DDSFLORG,DDSPG

 +17       IF '$PIECE(^DIST(.403,+DDS,40,+$GET(DDSSTACK),0),U,6)

               NEW DDSSC

 +18      ;

 +19       SET DDSPG=DDSSTACK

 +20       KILL DDSSTACK,DDSBR

 +21      ;

 +22       SET DDSDLORG=DDSDL

           SET DDSDAORG=DA

 +23       FOR DDSI=1:1:DDSDL

               SET DDSDAORG(DDSI)=DA(DDSI)

 +24       KILL DDSI

 +25      ;

 +26       SET DDSSTK=1

 +27       DO PROC^DDS

 +28       QUIT

 +29      ;

UPCASE(X) ;

 +1       ;Return X in uppercase

 +2        QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

DDSSTK.m