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 ---[H[J[2J[HQAOSCREE 1614 printed Nov 22, 2024@17:31:24 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
