QAOSPTR1 ;HISC/DAD-REVIEW LEVEL TRACKING REPORT ;2/12/93 15:28
;;3.0;Occurrence Screen;;09/14/1993
S QAOSQUIT=0,PAGE=1,Y=DT X ^DD("DD") S TODAY=$P(Y,"@"),HEAD2="AS OF "_TODAY K UNDL S $P(UNDL,"-",80)="-"
I '$D(^TMP($J,"QAOSPTR")) D HEAD W !!,"NO DATA FOUND FOR THIS REPORT" G EXIT
S SERV="" F SRV=0:0 S SERV=$O(^TMP($J,"QAOSPTR",SERV)) Q:SERV=""!QAOSQUIT D PAUSE:($E(IOST)="C")&(PAGE>1) Q:QAOSQUIT D HEAD,SHEAD F SCRN=0:0 S SCRN=$O(^TMP($J,"QAOSPTR",SERV,SCRN)) Q:SCRN'>0!QAOSQUIT D LOOP1
EXIT ;
Q
LOOP1 ;
S PAT="" F PT=0:0 S PAT=$O(^TMP($J,"QAOSPTR",SERV,SCRN,PAT)) Q:PAT=""!QAOSQUIT F DATE=0:0 S DATE=$O(^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE)) Q:DATE'>0!QAOSQUIT D LOOP2
Q
LOOP2 ;
S SSN=^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE),Y=DATE X ^DD("DD") S QAOSDT=$P(Y,"@")
I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD,SHEAD
W !!,PAT,?35,SSN,?49,QAOSDT,?65,SCRN
F LEVEL=QAOSCLIN,QAOSPEER,QAOSCMTE,QAOSMGMT Q:QAOSQUIT I $D(^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE,LEVEL)) F COUNT=0:0 S COUNT=$O(^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE,LEVEL,COUNT)) Q:COUNT'>0!QAOSQUIT D LOOP3
Q
LOOP3 ;
S X=^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE,LEVEL,COUNT),LOC=$P(^QA(741.2,LEVEL,0),"^"),LOC=LOC_$E(" ",1,11-$L(LOC)) W !?2,LOC,"#",$J(COUNT,2,0),": ",$E(X,1,60)
I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD,SHEAD W !!,PAT,?35,SSN,?49,QAOSDT,?65,SCRN
Q
HEAD ;
W:(PAGE>1)!($E(IOST)="C") @IOF
S X="REVIEW LEVEL TRACKING "_HEAD2
W !!?80-$L(X)/2,X,?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE S PAGE=PAGE+1 D EN6^QAQAUTL
W !,"PATIENT",?35,"SSN",?49,"OCCURRENCE",?65,"SCREEN",!," PREVIOUS REVIEWS",?49,"DATE",!,UNDL
Q
SHEAD ;
W !!?3,"SERVICE: ",$S(SERV["~":$P(SERV,"~",2),1:SERV)
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPTR1 1799 printed Apr 09, 2024@21:23:12 Page 2
QAOSPTR1 ;HISC/DAD-REVIEW LEVEL TRACKING REPORT ;2/12/93 15:28
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 SET QAOSQUIT=0
SET PAGE=1
SET Y=DT
XECUTE ^DD("DD")
SET TODAY=$PIECE(Y,"@")
SET HEAD2="AS OF "_TODAY
KILL UNDL
SET $PIECE(UNDL,"-",80)="-"
+3 IF '$DATA(^TMP($JOB,"QAOSPTR"))
DO HEAD
WRITE !!,"NO DATA FOUND FOR THIS REPORT"
GOTO EXIT
+4 SET SERV=""
FOR SRV=0:0
SET SERV=$ORDER(^TMP($JOB,"QAOSPTR",SERV))
if SERV=""!QAOSQUIT
QUIT
if ($EXTRACT(IOST)="C")&(PAGE>1)
DO PAUSE
if QAOSQUIT
QUIT
DO HEAD
DO SHEAD
FOR SCRN=0:0
SET SCRN=$ORDER(^TMP($JOB,"QAOSPTR",SERV,SCRN))
if SCRN'>0!QAOSQUIT
QUIT
DO LOOP1
EXIT ;
+1 QUIT
LOOP1 ;
+1 SET PAT=""
FOR PT=0:0
SET PAT=$ORDER(^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT))
if PAT=""!QAOSQUIT
QUIT
FOR DATE=0:0
SET DATE=$ORDER(^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE))
if DATE'>0!QAOSQUIT
QUIT
DO LOOP2
+2 QUIT
LOOP2 ;
+1 SET SSN=^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE)
SET Y=DATE
XECUTE ^DD("DD")
SET QAOSDT=$PIECE(Y,"@")
+2 IF $Y>(IOSL-6)
if $EXTRACT(IOST)="C"
DO PAUSE
if QAOSQUIT
QUIT
DO HEAD
DO SHEAD
+3 WRITE !!,PAT,?35,SSN,?49,QAOSDT,?65,SCRN
+4 FOR LEVEL=QAOSCLIN,QAOSPEER,QAOSCMTE,QAOSMGMT
if QAOSQUIT
QUIT
IF $DATA(^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE,LEVEL))
FOR COUNT=0:0
SET COUNT=$ORDER(^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE,LEVEL,COUNT))
if COUNT'>0!QAOSQUIT
QUIT
DO LOOP3
+5 QUIT
LOOP3 ;
+1 SET X=^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE,LEVEL,COUNT)
SET LOC=$PIECE(^QA(741.2,LEVEL,0),"^")
SET LOC=LOC_$EXTRACT(" ",1,11-$LENGTH(LOC))
WRITE !?2,LOC,"#",$JUSTIFY(COUNT,2,0),": ",$EXTRACT(X,1,60)
+2 IF $Y>(IOSL-6)
if $EXTRACT(IOST)="C"
DO PAUSE
if QAOSQUIT
QUIT
DO HEAD
DO SHEAD
WRITE !!,PAT,?35,SSN,?49,QAOSDT,?65,SCRN
+3 QUIT
HEAD ;
+1 if (PAGE>1)!($EXTRACT(IOST)="C")
WRITE @IOF
+2 SET X="REVIEW LEVEL TRACKING "_HEAD2
+3 WRITE !!?80-$LENGTH(X)/2,X,?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE
SET PAGE=PAGE+1
DO EN6^QAQAUTL
+4 WRITE !,"PATIENT",?35,"SSN",?49,"OCCURRENCE",?65,"SCREEN",!," PREVIOUS REVIEWS",?49,"DATE",!,UNDL
+5 QUIT
SHEAD ;
+1 WRITE !!?3,"SERVICE: ",$SELECT(SERV["~":$PIECE(SERV,"~",2),1:SERV)
+2 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+2 QUIT
