QAOSERCR ;HISC/DAD-ENTER EDIT REASONS FOR CLINICAL REFERRAL ;5/4/93 15:37
;;3.0;Occurrence Screen;;09/14/1993
LOOP0 ;
S DIC="^QA(741.1,",DIC(0)="AEMQ",DIC("A")="Select SCREEN: "
S DIC("S")="I $P(^(0),""^"",4)=""L"""
W ! D ^DIC K DIC G:+Y=-1 EXIT S QAOSSCRN=+Y,QAOSSCRN(0)=$P(Y,"^",2)
D LOOP1 G LOOP0
EXIT ;
K %,%Y,DA,DIDEL,DLAYGO,DIE,DR,DIC,LINE,QA,QADA,QAOSQUIT,QAOSSCRN,X,Y
K %H,C,D0,DI,DQ,I,Y,Z
Q
LOOP1 ;
R !!,"Select REASON CODE: ",X:DTIME S:'$T X="^" Q:(X="")!(X["^")
I $E(X)="?" D HELP G LOOP1
S DIC="^QA(741.4,",DIC(0)="ELMQ",DIC("DR")=""
S DIC("S")="I $P(^QA(741.4,+Y,1),""^"",2)=QAOSSCRN",(DIDEL,DLAYGO)=741.4
D ^DIC K DIC("S") G:+Y=-1 LOOP1
S DIE=DIC,DR="2///`"_QAOSSCRN_";.01REASON CODE;3;1",DA=+Y D ^DIE
G LOOP1
HELP ;
G:X?2."?".E H0
W:$D(^DD(741.4,.01,3))#2 !!?1,^(3)
W !!," ANSWER WITH QA OCCURRENCE CLINICAL REFERRAL REASON CODE, OR"
W !," REASON - SHORT",!," YOU MAY ENTER A NEW QA OCCURRENCE CLINICAL REFERRAL, IF YOU WISH"
HASK W !," DO YOU WANT THE ENTIRE QA OCCURRENCE CLINICAL REFERRAL LIST"
S %=0 D YN^DICN Q:(%=-1)!(%=2)!((%=0)&(%Y=""))
I '% W !!?5,"Please answer Y(es) or N(o)",! G HASK
H0 ;
S LINE=$Y,QAOSQUIT=0 W !!,"CHOOSE FROM:"
F QA=0:0 S QA=$O(^QA(741.4,"AC",QAOSSCRN,QA)) Q:QA=""!QAOSQUIT F QADA=0:0 S QADA=$O(^QA(741.4,"AC",QAOSSCRN,QA,QADA)) Q:QADA'>0!QAOSQUIT D H1
W ! S QAOSQUIT=0
F QA=0:0 S QA=$O(^DD(741.4,.01,21,QA)) Q:QA'>0!QAOSQUIT W !?1,^DD(741.4,.01,21,QA,0) D H2
Q
H1 ;
I $D(^QA(741.4,QADA,0))#2 W !?3,$P(^(0),"^") W:$D(^(2))#2 " ",$P(^(2),"^")
H2 I $Y>(IOSL+LINE-3) S LINE=$Y K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSERCR 1658 printed Dec 13, 2024@02:21:29 Page 2
QAOSERCR ;HISC/DAD-ENTER EDIT REASONS FOR CLINICAL REFERRAL ;5/4/93 15:37
+1 ;;3.0;Occurrence Screen;;09/14/1993
LOOP0 ;
+1 SET DIC="^QA(741.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select SCREEN: "
+2 SET DIC("S")="I $P(^(0),""^"",4)=""L"""
+3 WRITE !
DO ^DIC
KILL DIC
if +Y=-1
GOTO EXIT
SET QAOSSCRN=+Y
SET QAOSSCRN(0)=$PIECE(Y,"^",2)
+4 DO LOOP1
GOTO LOOP0
EXIT ;
+1 KILL %,%Y,DA,DIDEL,DLAYGO,DIE,DR,DIC,LINE,QA,QADA,QAOSQUIT,QAOSSCRN,X,Y
+2 KILL %H,C,D0,DI,DQ,I,Y,Z
+3 QUIT
LOOP1 ;
+1 READ !!,"Select REASON CODE: ",X:DTIME
if '$TEST
SET X="^"
if (X="")!(X["^")
QUIT
+2 IF $EXTRACT(X)="?"
DO HELP
GOTO LOOP1
+3 SET DIC="^QA(741.4,"
SET DIC(0)="ELMQ"
SET DIC("DR")=""
+4 SET DIC("S")="I $P(^QA(741.4,+Y,1),""^"",2)=QAOSSCRN"
SET (DIDEL,DLAYGO)=741.4
+5 DO ^DIC
KILL DIC("S")
if +Y=-1
GOTO LOOP1
+6 SET DIE=DIC
SET DR="2///`"_QAOSSCRN_";.01REASON CODE;3;1"
SET DA=+Y
DO ^DIE
+7 GOTO LOOP1
HELP ;
+1 if X?2."?".E
GOTO H0
+2 if $DATA(^DD(741.4,.01,3))#2
WRITE !!?1,^(3)
+3 WRITE !!," ANSWER WITH QA OCCURRENCE CLINICAL REFERRAL REASON CODE, OR"
+4 WRITE !," REASON - SHORT",!," YOU MAY ENTER A NEW QA OCCURRENCE CLINICAL REFERRAL, IF YOU WISH"
HASK WRITE !," DO YOU WANT THE ENTIRE QA OCCURRENCE CLINICAL REFERRAL LIST"
+1 SET %=0
DO YN^DICN
if (%=-1)!(%=2)!((%=0)&(%Y=""))
QUIT
+2 IF '%
WRITE !!?5,"Please answer Y(es) or N(o)",!
GOTO HASK
H0 ;
+1 SET LINE=$Y
SET QAOSQUIT=0
WRITE !!,"CHOOSE FROM:"
+2 FOR QA=0:0
SET QA=$ORDER(^QA(741.4,"AC",QAOSSCRN,QA))
if QA=""!QAOSQUIT
QUIT
FOR QADA=0:0
SET QADA=$ORDER(^QA(741.4,"AC",QAOSSCRN,QA,QADA))
if QADA'>0!QAOSQUIT
QUIT
DO H1
+3 WRITE !
SET QAOSQUIT=0
+4 FOR QA=0:0
SET QA=$ORDER(^DD(741.4,.01,21,QA))
if QA'>0!QAOSQUIT
QUIT
WRITE !?1,^DD(741.4,.01,21,QA,0)
DO H2
+5 QUIT
H1 ;
+1 IF $DATA(^QA(741.4,QADA,0))#2
WRITE !?3,$PIECE(^(0),"^")
if $DATA(^(2))#2
WRITE " ",$PIECE(^(2),"^")
H2 IF $Y>(IOSL+LINE-3)
SET LINE=$Y
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+1 QUIT
