ASUAUDIR.m

ASUAUDIR ;DSD/DFM - STANDARD POINTER TYPE READ ROUTINE WITH SCREENING;  [ 04/15/98  2:50 PM ]

 ;;3.0;SAMS;**1**;AUG 20, 1993

 ;THIS ROUTINE IS NEEDED TO DO SCREENING ON POINTER TYPE CALLS WHICH

 ;WOULD NORMALLY CALL DIR - WHEN DIR IS FIXED TO HANDLE SCREENING,

 ;THIS ROUTINE CAN BE DELETED AND ALL CALLS TO IT BE REPLACED WITH

 ;CALLS TO DIR

DIR ;

 S:$D(DIR("S")) DIC("S")=DIR("S")

 W !,DIR("A"),": "

 W:$D(DIR("B")) DIR("B"),"// "

 R X:DTIME

 I '$T S DTOUT=1 G EXIT

 S DIC=$P($P(DIR(0),U,2),":",1)

 I X="?",DIC=9002039.07,$D(ASUTRNS(ASUTRNS,"SUB OBJECT")),$D(ASUTR(0,"ACCOUNT")) D HELP7 G DIR

 I X="!" S X="" G DIR

 I X="",$D(DIR("B")) S X=DIR("B") K DIR("B") G READ

 I X="@" S X=""

 I X="",$P(DIR(0),U)["O" S Y=X G EXIT E  W !!,"This is a required entry.  Enter '^' to exit or '?' to see valid codes.",!! G DIR

 I X="^" K X S DUOUT=1 G EXIT

 I X="^^" K X S DIROUT=1 G EXIT

 I X'=" " G READ

 I '$D(DUZ) G NOSAVE

 I $E(DIC)?1"^" S ASUDIC=DIC G CKDISV

 I $E(DIC)?1A S ASUDIC=U_DIC G CKDISV

 I $E(DIC)?1N S ASUDIC=^DIC(DIC,0,"GL")

 I '$D(ASUDIC) G NOSAVE

 I ASUDIC']"" G NOSAVE

CKDISV ;

 I '$D(^DISV(DUZ,ASUDIC)) G NOSAVE

 G READ

NOSAVE ;

 W !,"Previous entry not available" G DIR

READ ;

 S:DIC'?1N.E DIC=U_DIC

 S DIC(0)=$P($P(DIR(0),U,2),":",2)

 D ^DIC I X="?" G DIR

 I Y<0 W *7,!!,DIR("?"),!,"Enter '^' to exit or '?' to see valid codes",!! G DIR

 I X=" " W $P(Y,U,2)

EXIT ;RETURN TO CALLING ROUTINE

 K ASUDIC,DIC

 Q

HELP7 ;

 S ASUTR(7,"CAT")=""

 F  S ASUTR(7,"CAT")=$O(^ASUTB07("D",ASUTRNS(ASUTRNS,"SUB OBJECT"),ASUTR(7,"CAT"))) Q:ASUTR(7,"CAT")=""  D

 .S ASUTR(7,"SOBJ")=$O(^ASUTB07("D",ASUTRNS(ASUTRNS,"SUB OBJECT"),ASUTR(7,"CAT"),""))

 .Q:$P(^ASUTB07(ASUTR(7,"CAT"),1,ASUTR(7,"SOBJ"),0),U)'=ASUTR(0,"ACCOUNT")

 .W !?5,^ASUTB07(ASUTR(7,"CAT"),0),?10,$P(^ASUTB07(ASUTR(7,"CAT"),1,ASUTR(7,"SOBJ"),0),U,3)

 K ASUTR(7,"CAT"),ASUTR(7,"SOBJ")

 Q

ASUAUDIR  ;DSD/DFM - STANDARD POINTER TYPE READ ROUTINE WITH SCREENING;  [ 04/15/98  2:50 PM ]

 +1       ;;3.0;SAMS;**1**;AUG 20, 1993

 +2       ;THIS ROUTINE IS NEEDED TO DO SCREENING ON POINTER TYPE CALLS WHICH

 +3       ;WOULD NORMALLY CALL DIR - WHEN DIR IS FIXED TO HANDLE SCREENING,

 +4       ;THIS ROUTINE CAN BE DELETED AND ALL CALLS TO IT BE REPLACED WITH

 +5       ;CALLS TO DIR

DIR       ;

 +1        IF $DATA(DIR("S"))

               SET DIC("S")=DIR("S")

 +2        WRITE !,DIR("A"),": "

 +3        IF $DATA(DIR("B"))

               WRITE DIR("B"),"// "

 +4        READ X:DTIME

 +5        IF '$TEST

               SET DTOUT=1

               GOTO EXIT

 +6        SET DIC=$PIECE($PIECE(DIR(0),U,2),":",1)

 +7        IF X="?"

               IF DIC=9002039.07

                   IF $DATA(ASUTRNS(ASUTRNS,"SUB OBJECT"))

                       IF $DATA(ASUTR(0,"ACCOUNT"))

                           DO HELP7

                           GOTO DIR

 +8        IF X="!"

               SET X=""

               GOTO DIR

 +9        IF X=""

               IF $DATA(DIR("B"))

                   SET X=DIR("B")

                   KILL DIR("B")

                   GOTO READ

 +10       IF X="@"

               SET X=""

 +11       IF X=""

               IF $PIECE(DIR(0),U)["O"

                   SET Y=X

                   GOTO EXIT

                  IF '$TEST

                       WRITE !!,"This is a required entry.  Enter '^' to exit or '?' to see valid codes.",!!

                       GOTO DIR

 +12       IF X="^"

               KILL X

               SET DUOUT=1

               GOTO EXIT

 +13       IF X="^^"

               KILL X

               SET DIROUT=1

               GOTO EXIT

 +14       IF X'=" "

               GOTO READ

 +15       IF '$DATA(DUZ)

               GOTO NOSAVE

 +16       IF $EXTRACT(DIC)?1"^"

               SET ASUDIC=DIC

               GOTO CKDISV

 +17       IF $EXTRACT(DIC)?1A

               SET ASUDIC=U_DIC

               GOTO CKDISV

 +18       IF $EXTRACT(DIC)?1N

               SET ASUDIC=^DIC(DIC,0,"GL")

 +19       IF '$DATA(ASUDIC)

               GOTO NOSAVE

 +20       IF ASUDIC']""

               GOTO NOSAVE

CKDISV    ;

 +1        IF '$DATA(^DISV(DUZ,ASUDIC))

               GOTO NOSAVE

 +2        GOTO READ

NOSAVE    ;

 +1        WRITE !,"Previous entry not available"

           GOTO DIR

READ      ;

 +1        IF DIC'?1N.E

               SET DIC=U_DIC

 +2        SET DIC(0)=$PIECE($PIECE(DIR(0),U,2),":",2)

 +3        DO ^DIC

           IF X="?"

               GOTO DIR

 +4        IF Y<0

               WRITE *7,!!,DIR("?"),!,"Enter '^' to exit or '?' to see valid codes",!!

               GOTO DIR

 +5        IF X=" "

               WRITE $PIECE(Y,U,2)

EXIT      ;RETURN TO CALLING ROUTINE

 +1        KILL ASUDIC,DIC

 +2        QUIT 

HELP7     ;

 +1        SET ASUTR(7,"CAT")=""

 +2        FOR 

               SET ASUTR(7,"CAT")=$ORDER(^ASUTB07("D",ASUTRNS(ASUTRNS,"SUB OBJECT"),ASUTR(7,"CAT")))

               IF ASUTR(7,"CAT")=""

                   QUIT 

               Begin DoDot:1

 +3                SET ASUTR(7,"SOBJ")=$ORDER(^ASUTB07("D",ASUTRNS(ASUTRNS,"SUB OBJECT"),ASUTR(7,"CAT"),""))

 +4                IF $PIECE(^ASUTB07(ASUTR(7,"CAT"),1,ASUTR(7,"SOBJ"),0),U)'=ASUTR(0,"ACCOUNT")

                       QUIT 

 +5                WRITE !?5,^ASUTB07(ASUTR(7,"CAT"),0),?10,$PIECE(^ASUTB07(ASUTR(7,"CAT"),1,ASUTR(7,"SOBJ"),0),U,3)

               End DoDot:1

 +6        KILL ASUTR(7,"CAT"),ASUTR(7,"SOBJ")

 +7        QUIT