QAOSCREE.m

QAOSCREE ;HISC/JES,DAD-ADD OR CHANGE VAMC SPECIFIC OCCURRENCE SCREENS ;2/4/93  08:11

 ;;3.0;Occurrence Screen;;09/14/1993

 ;THIS ROUTINE PROVIDES THE OPTION TO ADD VAMC-SPECIFIC SCREENS IN THE

 ;RANGE OF 201 TO 999.99, AND ALSO TO ENTER CORRESPONDING EXCEPTIONS

EDSCREE ;

 R !!,"Select SCREEN: ",X:DTIME S:'$T X="^" G:(X="")!(X="^") EXIT

 I X?1.N.NP,((X<101)!(X>999.99)!($P($G(^QA(741.1,+X,0)),"^",4)="N")) D  G EDSCREE

 . W " ??",*7,!

 . W !?5,"Answer with a number from 101 to 999.99."

 . W !?5,"You may not select 'NATIONAL' screens."

 . Q

 S (DIC,DIE)="^QA(741.1,",DIC("A")="Select SCREEN: ",DIC(0)="ELMQZ"

 S DIC("S")="I $P(^(0),""^"",4)'=""N""",(DIDEL,DLAYGO)=741.1

 D ^DIC K DIC("S") G:+Y=-1 EDSCREE S (QAPOINT,DA)=+Y

 S DR=".01;1T;2T;100//LOCAL" D ^DIE

 D:'$D(DA) KILLXCPT G:('$D(DA))!($D(Y)) EDSCREE

 I $D(^QA(741.1,QAPOINT,0))#2,$P(^(0),"^",4)'>0 D EDEXCPT

 G EDSCREE

EDEXCPT ;

 S (DIC,DIE)="^QA(741.5,",DIC("A")="Select REASON FOR EXCEPTION: "

 S DIC(0)="AELMQ",DIC("DR")="",(DIDEL,DLAYGO)=741.5

 S DIC("S")="I $P(^QA(741.5,+Y,0),""^"",2)=QAPOINT"

 D ^DIC K DIC("DR"),DIC("S") Q:+Y=-1

 S DA=+Y,DR="1///`"_QAPOINT_";.01;.02;100//ACTIVE"

 D ^DIE Q:$D(Y)

 G EDEXCPT

KILLXCPT ;

 S DIK="^QA(741.5,"

 F QADA=0:0 S QADA=$O(^QA(741.5,"C",QAPOINT,QADA)) Q:QADA'>0  S DA=QADA D ^DIK

 S DIK="^QA(741.4," F QADA(0)=0:0 S QADA(0)=$O(^QA(741.4,"AC",QAPOINT,QADA(0))) Q:QADA(0)'>0  F QADA=0:0 S QADA=$O(^QA(741.4,"AC",QAPOINT,QADA(0),QADA)) Q:QADA'>0  S DA=QADA D ^DIK

 K DA,DIK,QADA

 Q

EXIT ;

 K DA,DIC,DIE,DIK,DR,DIDEL,DLAYGO,QAPOINT,QADA,X,Y

 K %,%H,C,D0,DI,DQ,I,Y,Z,DG,DK,DL

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---QAOSCREE   1614     printed  Apr 09, 2024@21:22:32                                                                                                                                                                                                    Page 2

QAOSCREE  ;HISC/JES,DAD-ADD OR CHANGE VAMC SPECIFIC OCCURRENCE SCREENS ;2/4/93  08:11

 +1       ;;3.0;Occurrence Screen;;09/14/1993

 +2       ;THIS ROUTINE PROVIDES THE OPTION TO ADD VAMC-SPECIFIC SCREENS IN THE

 +3       ;RANGE OF 201 TO 999.99, AND ALSO TO ENTER CORRESPONDING EXCEPTIONS

EDSCREE   ;

 +1        READ !!,"Select SCREEN: ",X:DTIME

           if '$TEST

               SET X="^"

           if (X="")!(X="^")

               GOTO EXIT

 +2        IF X?1.N.NP

               IF ((X<101)!(X>999.99)!($PIECE($GET(^QA(741.1,+X,0)),"^",4)="N"))

                   Begin DoDot:1

 +3                    WRITE " ??",*7,!

 +4                    WRITE !?5,"Answer with a number from 101 to 999.99."

 +5                    WRITE !?5,"You may not select 'NATIONAL' screens."

 +6                    QUIT 

                   End DoDot:1

                   GOTO EDSCREE

 +7        SET (DIC,DIE)="^QA(741.1,"

           SET DIC("A")="Select SCREEN: "

           SET DIC(0)="ELMQZ"

 +8        SET DIC("S")="I $P(^(0),""^"",4)'=""N"""

           SET (DIDEL,DLAYGO)=741.1

 +9        DO ^DIC

           KILL DIC("S")

           if +Y=-1

               GOTO EDSCREE

           SET (QAPOINT,DA)=+Y

 +10       SET DR=".01;1T;2T;100//LOCAL"

           DO ^DIE

 +11       if '$DATA(DA)

               DO KILLXCPT

           if ('$DATA(DA))!($DATA(Y))

               GOTO EDSCREE

 +12       IF $DATA(^QA(741.1,QAPOINT,0))#2

               IF $PIECE(^(0),"^",4)'>0

                   DO EDEXCPT

 +13       GOTO EDSCREE

EDEXCPT   ;

 +1        SET (DIC,DIE)="^QA(741.5,"

           SET DIC("A")="Select REASON FOR EXCEPTION: "

 +2        SET DIC(0)="AELMQ"

           SET DIC("DR")=""

           SET (DIDEL,DLAYGO)=741.5

 +3        SET DIC("S")="I $P(^QA(741.5,+Y,0),""^"",2)=QAPOINT"

 +4        DO ^DIC

           KILL DIC("DR"),DIC("S")

           if +Y=-1

               QUIT 

 +5        SET DA=+Y

           SET DR="1///`"_QAPOINT_";.01;.02;100//ACTIVE"

 +6        DO ^DIE

           if $DATA(Y)

               QUIT 

 +7        GOTO EDEXCPT

KILLXCPT  ;

 +1        SET DIK="^QA(741.5,"

 +2        FOR QADA=0:0

               SET QADA=$ORDER(^QA(741.5,"C",QAPOINT,QADA))

               if QADA'>0

                   QUIT 

               SET DA=QADA

               DO ^DIK

 +3        SET DIK="^QA(741.4,"

           FOR QADA(0)=0:0

               SET QADA(0)=$ORDER(^QA(741.4,"AC",QAPOINT,QADA(0)))

               if QADA(0)'>0

                   QUIT 

               FOR QADA=0:0

                   SET QADA=$ORDER(^QA(741.4,"AC",QAPOINT,QADA(0),QADA))

                   if QADA'>0

                       QUIT 

                   SET DA=QADA

                   DO ^DIK

 +4        KILL DA,DIK,QADA

 +5        QUIT 

EXIT      ;

 +1        KILL DA,DIC,DIE,DIK,DR,DIDEL,DLAYGO,QAPOINT,QADA,X,Y

 +2        KILL %,%H,C,D0,DI,DQ,I,Y,Z,DG,DK,DL

 +3        QUIT