source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSPSM1.m@ 623

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

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1QAOSPSM1 ;HISC/DAD-SUMMARY OF OCCURRENCE SCREENING - PART I ;11/20/92 15:39
2 ;;3.0;Occurrence Screen;;09/14/1993
3 K UNDL S $P(UNDL,"_",81)="",QAOSQUIT=0,QAOSSITE=+$G(^QA(740,1,0)),QAOSSITE=$P($G(^DIC(4,QAOSSITE,0)),"^")
4 F QAOSLST=2:1 S QAOSLST(0)=$P(QAOSLIST,"^",QAOSLST) Q:QAOSLST(0)=""!QAOSQUIT D LOOP0
5 Q
6LOOP0 ;
7 Q:$O(^UTILITY($J,"QAOSPSM",QAOSLST(0),0))'>0 S QAOSPAGE=1 D HDR
8 F QAOSSEQ=0:0 S QAOSSEQ=$O(^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ)) Q:QAOSSEQ'>0!QAOSQUIT D LOOP1
9 Q
10LOOP1 ;
11 S QAOSTEMP=^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ),X=$P(QAOSTEMP,"^") W !!,$J(QAOSSEQ,2)," (",X,")"
12 S TAB=15 F QA=2:1:9 S X=+$P(QAOSTEMP,"^",QA) W ?TAB,$S(QAOBLANK'>0:$J(X,4),1:" ____") S TAB=TAB+8
13 I $Y>(IOSL-6),$O(^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ)) D PAUSE:$E(IOST)="C",HDR:'QAOSQUIT Q
14 I $O(^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ))'>0 W !!,"COMMENTS:" D:$E(IOST)="C" PAUSE
15 Q
16HDR ;
17 W:(QAOSPAGE>1)!($E(IOST)="C") @IOF S QAOSPAGE=QAOSPAGE+1
18 S X="SUMMARY OF OCCURRENCE SCREENING - SEMI-ANNUAL REPORT - PART I"_$S(QAOSLST(0)="L":" (LOCAL SCREENS)",QAOSLST(0)="1":" (INACTIVE SCREENS)",1:""),TAB=80-$L(X)/2
19 W !!?TAB,X,!?TAB,$TR($J("",$L(X))," ","-")
20 W !!,"MEDICAL CENTER: ",$S(QAOBLANK:$E(UNDL,1,64),1:QAOSSITE)
21 W !!,"PERSON PREPARING REPORT: ",$E(UNDL,1,55)
22 W !!,"TITLE & CORRESPONDENCE SYMBOL OF THE ABOVE: ",$E(UNDL,1,36)
23 W !!,"FTS TELEPHONE: ",$E(UNDL,1,27)," TELEFAX: ",$E(UNDL,1,28)
24 W !!,"REPORTING PERIOD: ",$S(QAOBLANK:$E(UNDL,1,62),1:QAQ2HED),!
25 W !,"|CRITERION|--# OF OCCURRENCES---|--OUTCOME OF PEER REVIEW---|-# OF OCCURRENCES-|"
26 W !,"| SCREEN | REVIEWED REFERRED |LEVEL LEVEL LEVEL PENDING| REFERRED FOR |"
27 W !,"| | CLINICALLY TO PEER | 1 2 3 | SYSTEM EQUIPMENT|"
28 W !,"|=========|=====================|===========================|==================|"
29 Q
30PAUSE ;
31 K DIR S DIR(0)="E" D ^DIR S QAOSQUIT=$S(Y'>0:1,1:0)
32 Q
Note: See TracBrowser for help on using the repository browser.