QAOSPSM1 ;HISC/DAD-SUMMARY OF OCCURRENCE SCREENING - PART I ;11/20/92 15:39
;;3.0;Occurrence Screen;;09/14/1993
K UNDL S $P(UNDL,"_",81)="",QAOSQUIT=0,QAOSSITE=+$G(^QA(740,1,0)),QAOSSITE=$P($G(^DIC(4,QAOSSITE,0)),"^")
F QAOSLST=2:1 S QAOSLST(0)=$P(QAOSLIST,"^",QAOSLST) Q:QAOSLST(0)=""!QAOSQUIT D LOOP0
Q
LOOP0 ;
Q:$O(^UTILITY($J,"QAOSPSM",QAOSLST(0),0))'>0 S QAOSPAGE=1 D HDR
F QAOSSEQ=0:0 S QAOSSEQ=$O(^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ)) Q:QAOSSEQ'>0!QAOSQUIT D LOOP1
Q
LOOP1 ;
S QAOSTEMP=^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ),X=$P(QAOSTEMP,"^") W !!,$J(QAOSSEQ,2)," (",X,")"
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
I $Y>(IOSL-6),$O(^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ)) D PAUSE:$E(IOST)="C",HDR:'QAOSQUIT Q
I $O(^UTILITY($J,"QAOSPSM",QAOSLST(0),QAOSSEQ))'>0 W !!,"COMMENTS:" D:$E(IOST)="C" PAUSE
Q
HDR ;
W:(QAOSPAGE>1)!($E(IOST)="C") @IOF S QAOSPAGE=QAOSPAGE+1
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
W !!?TAB,X,!?TAB,$TR($J("",$L(X))," ","-")
W !!,"MEDICAL CENTER: ",$S(QAOBLANK:$E(UNDL,1,64),1:QAOSSITE)
W !!,"PERSON PREPARING REPORT: ",$E(UNDL,1,55)
W !!,"TITLE & CORRESPONDENCE SYMBOL OF THE ABOVE: ",$E(UNDL,1,36)
W !!,"FTS TELEPHONE: ",$E(UNDL,1,27)," TELEFAX: ",$E(UNDL,1,28)
W !!,"REPORTING PERIOD: ",$S(QAOBLANK:$E(UNDL,1,62),1:QAQ2HED),!
W !,"|CRITERION|--# OF OCCURRENCES---|--OUTCOME OF PEER REVIEW---|-# OF OCCURRENCES-|"
W !,"| SCREEN | REVIEWED REFERRED |LEVEL LEVEL LEVEL PENDING| REFERRED FOR |"
W !,"| | CLINICALLY TO PEER | 1 2 3 | SYSTEM EQUIPMENT|"
W !,"|=========|=====================|===========================|==================|"
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR S QAOSQUIT=$S(Y'>0:1,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPSM1 1923 printed Apr 09, 2024@21:23:20 Page 2
QAOSPSM1 ;HISC/DAD-SUMMARY OF OCCURRENCE SCREENING - PART I ;11/20/92 15:39
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 KILL UNDL
SET $PIECE(UNDL,"_",81)=""
SET QAOSQUIT=0
SET QAOSSITE=+$GET(^QA(740,1,0))
SET QAOSSITE=$PIECE($GET(^DIC(4,QAOSSITE,0)),"^")
+3 FOR QAOSLST=2:1
SET QAOSLST(0)=$PIECE(QAOSLIST,"^",QAOSLST)
if QAOSLST(0)=""!QAOSQUIT
QUIT
DO LOOP0
+4 QUIT
LOOP0 ;
+1 if $ORDER(^UTILITY($JOB,"QAOSPSM",QAOSLST(0),0))'>0
QUIT
SET QAOSPAGE=1
DO HDR
+2 FOR QAOSSEQ=0:0
SET QAOSSEQ=$ORDER(^UTILITY($JOB,"QAOSPSM",QAOSLST(0),QAOSSEQ))
if QAOSSEQ'>0!QAOSQUIT
QUIT
DO LOOP1
+3 QUIT
LOOP1 ;
+1 SET QAOSTEMP=^UTILITY($JOB,"QAOSPSM",QAOSLST(0),QAOSSEQ)
SET X=$PIECE(QAOSTEMP,"^")
WRITE !!,$JUSTIFY(QAOSSEQ,2)," (",X,")"
+2 SET TAB=15
FOR QA=2:1:9
SET X=+$PIECE(QAOSTEMP,"^",QA)
WRITE ?TAB,$SELECT(QAOBLANK'>0:$JUSTIFY(X,4),1:" ____")
SET TAB=TAB+8
+3 IF $Y>(IOSL-6)
IF $ORDER(^UTILITY($JOB,"QAOSPSM",QAOSLST(0),QAOSSEQ))
if $EXTRACT(IOST)="C"
DO PAUSE
if 'QAOSQUIT
DO HDR
QUIT
+4 IF $ORDER(^UTILITY($JOB,"QAOSPSM",QAOSLST(0),QAOSSEQ))'>0
WRITE !!,"COMMENTS:"
if $EXTRACT(IOST)="C"
DO PAUSE
+5 QUIT
HDR ;
+1 if (QAOSPAGE>1)!($EXTRACT(IOST)="C")
WRITE @IOF
SET QAOSPAGE=QAOSPAGE+1
+2 SET X="SUMMARY OF OCCURRENCE SCREENING - SEMI-ANNUAL REPORT - PART I"_$SELECT(QAOSLST(0)="L":" (LOCAL SCREENS)",QAOSLST(0)="1":" (INACTIVE SCREENS)",1:"")
SET TAB=80-$LENGTH(X)/2
+3 WRITE !!?TAB,X,!?TAB,$TRANSLATE($JUSTIFY("",$LENGTH(X))," ","-")
+4 WRITE !!,"MEDICAL CENTER: ",$SELECT(QAOBLANK:$EXTRACT(UNDL,1,64),1:QAOSSITE)
+5 WRITE !!,"PERSON PREPARING REPORT: ",$EXTRACT(UNDL,1,55)
+6 WRITE !!,"TITLE & CORRESPONDENCE SYMBOL OF THE ABOVE: ",$EXTRACT(UNDL,1,36)
+7 WRITE !!,"FTS TELEPHONE: ",$EXTRACT(UNDL,1,27)," TELEFAX: ",$EXTRACT(UNDL,1,28)
+8 WRITE !!,"REPORTING PERIOD: ",$SELECT(QAOBLANK:$EXTRACT(UNDL,1,62),1:QAQ2HED),!
+9 WRITE !,"|CRITERION|--# OF OCCURRENCES---|--OUTCOME OF PEER REVIEW---|-# OF OCCURRENCES-|"
+10 WRITE !,"| SCREEN | REVIEWED REFERRED |LEVEL LEVEL LEVEL PENDING| REFERRED FOR |"
+11 WRITE !,"| | CLINICALLY TO PEER | 1 2 3 | SYSTEM EQUIPMENT|"
+12 WRITE !,"|=========|=====================|===========================|==================|"
+13 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+2 QUIT
