source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSPCM0.m@ 767

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1QAOSPCM0 ;HISC/DAD-COMMITTEE REVIEWER WORKSHEET ;2/16/93 09:19
2 ;;3.0;Occurrence Screen;;09/14/1993
3 S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN")),QAOSCOMM=$O(^QA(741.2,"C",4,0)),QAOSREVR=4,QAOSQUIT=0
4 I QAOSDATA=1 S QAOSD1="" D LOOP1 W:$E(IOST)'="C" @IOF D G EXIT
5 . Q:$E(IOST)'="C" Q:QAOSQUIT
6 . K DIR S DIR(0)="E" D ^DIR K DIR
7 . S QAOSQUIT=$S(Y'>0:1,1:0)
8 . Q
9 I QAOSDATA=2,'$D(^QA(741,QAOSD0,"CMTE","B")) S QAOSD1="" D LOOP1 W:$E(IOST)'="C" @IOF D G EXIT
10 . Q:$E(IOST)'="C" Q:QAOSQUIT
11 . K DIR S DIR(0)="E" D ^DIR K DIR
12 . S QAOSQUIT=$S(Y'>0:1,1:0)
13 . Q
14 F QAOSCOMM=0:0 S QAOSCOMM=$O(^QA(741,QAOSD0,"CMTE","B",QAOSCOMM)) Q:QAOSCOMM'>0!QAOSQUIT D LOOP0
15EXIT ;
16 K ARRAY,CODE,CODES,D0,DIWF,DIWL,DIWR,LOC,QA,QAOSD1,QAOSHEAD,QAOSMULT,QAOSPAGE,QAOSREVR,QAOSSCRN,QAOSCOMM,X,XX,Y
17 Q
18LOOP0 ;
19 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE","B",QAOSCOMM,QAOSD1)) Q:QAOSD1'>0!QAOSQUIT D LOOP1 W:$E(IOST)'="C" @IOF I ('QAOSQUIT),$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0) Q:QAOSQUIT
20 Q
21LOOP1 ;
22 S QAOSMULT=$S(QAOSD1'>0:"",$D(^QA(741,QAOSD0,"CMTE",QAOSD1,0))#2:^(0),1:"")
23 S QA=$P(QAOSMULT,"^") S $P(QAOSREVR,"^",2)=$S(QA'>0:"",$D(^QA(741.97,QA,0))#2:$P(^(0),"^"),1:"")
24 S QAOSPAGE=1 D ^QAOSPHDR
25 S QAOSHEAD="CONFIRMED ISSUE" W !!,QAOSHEAD S LOC=$P(QAOSMULT,"^",5),CODES=$P(^DD(741.017,4,0),"^",3)
26 F QA=1:1:$L(CODES,";")-1 S CODE=$P(CODES,";",QA) W !?3,$S(LOC=+CODE:"_X_",1:"___"),?8,$J(+CODE,3,0),?15,$P(CODE,":",2) D CHK Q:QAOSQUIT
27 G:QAOSQUIT EXIT
28 S QAOSHEAD="COMMENTS" W !!,QAOSHEAD S DIWL=4,DIWR=75,DIWF="" K ^UTILITY($J,"W")
29 I QAOSHOW'=3,QAOSDATA=2 F QAOSS0=0:0 S QAOSS0=$O(^QA(741,QAOSD0,"CMTE",+QAOSD1,1,QAOSS0)) Q:QAOSS0'>0 S X=^QA(741,QAOSD0,"CMTE",QAOSD1,1,QAOSS0,0) D ^DIWP
30 F QA=0:0 S QA=$O(^UTILITY($J,"W",DIWL,QA)) Q:QA'>0!QAOSQUIT W !?3,^UTILITY($J,"W",DIWL,QA,0) D CHK
31 Q:QAOSQUIT
32BLANK I $Y<(IOSL-6) W ! G BLANK
33 W !,"SIGNATURE"
34 Q
35CHK ;
36 Q:$Y'>(IOSL-6) N D0,QA,Y I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0) Q:QAOSQUIT
37 D ^QAOSPHDR W !!,QAOSHEAD
38 Q
Note: See TracBrowser for help on using the repository browser.