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