source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSERCR.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.6 KB
Line 
1QAOSERCR ;HISC/DAD-ENTER EDIT REASONS FOR CLINICAL REFERRAL ;5/4/93 15:37
2 ;;3.0;Occurrence Screen;;09/14/1993
3LOOP0 ;
4 S DIC="^QA(741.1,",DIC(0)="AEMQ",DIC("A")="Select SCREEN: "
5 S DIC("S")="I $P(^(0),""^"",4)=""L"""
6 W ! D ^DIC K DIC G:+Y=-1 EXIT S QAOSSCRN=+Y,QAOSSCRN(0)=$P(Y,"^",2)
7 D LOOP1 G LOOP0
8EXIT ;
9 K %,%Y,DA,DIDEL,DLAYGO,DIE,DR,DIC,LINE,QA,QADA,QAOSQUIT,QAOSSCRN,X,Y
10 K %H,C,D0,DI,DQ,I,Y,Z
11 Q
12LOOP1 ;
13 R !!,"Select REASON CODE: ",X:DTIME S:'$T X="^" Q:(X="")!(X["^")
14 I $E(X)="?" D HELP G LOOP1
15 S DIC="^QA(741.4,",DIC(0)="ELMQ",DIC("DR")=""
16 S DIC("S")="I $P(^QA(741.4,+Y,1),""^"",2)=QAOSSCRN",(DIDEL,DLAYGO)=741.4
17 D ^DIC K DIC("S") G:+Y=-1 LOOP1
18 S DIE=DIC,DR="2///`"_QAOSSCRN_";.01REASON CODE;3;1",DA=+Y D ^DIE
19 G LOOP1
20HELP ;
21 G:X?2."?".E H0
22 W:$D(^DD(741.4,.01,3))#2 !!?1,^(3)
23 W !!," ANSWER WITH QA OCCURRENCE CLINICAL REFERRAL REASON CODE, OR"
24 W !," REASON - SHORT",!," YOU MAY ENTER A NEW QA OCCURRENCE CLINICAL REFERRAL, IF YOU WISH"
25HASK W !," DO YOU WANT THE ENTIRE QA OCCURRENCE CLINICAL REFERRAL LIST"
26 S %=0 D YN^DICN Q:(%=-1)!(%=2)!((%=0)&(%Y=""))
27 I '% W !!?5,"Please answer Y(es) or N(o)",! G HASK
28H0 ;
29 S LINE=$Y,QAOSQUIT=0 W !!,"CHOOSE FROM:"
30 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
31 W ! S QAOSQUIT=0
32 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
33 Q
34H1 ;
35 I $D(^QA(741.4,QADA,0))#2 W !?3,$P(^(0),"^") W:$D(^(2))#2 " ",$P(^(2),"^")
36H2 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)
37 Q
Note: See TracBrowser for help on using the repository browser.