QAOSPTR0 ;HISC/DAD-REVIEW LEVEL TRACKING REPORT ;10/19/92 15:24
;;3.0;Occurrence Screen;;09/14/1993
D ^QAQDATE G:QAQQUIT EXIT
K %ZIS S %ZIS="QM" D ^%ZIS G:POP EXIT I $D(IO("Q")) S ZTDESC="Review level tracking report",ZTRTN="ENTSK^QAOSPTR0",ZTSAVE("QAQ*")="" D ^%ZTLOAD G EXIT
ENTSK ;
S QAOSCLIN=$O(^QA(741.2,"C",1,0)),QAOSPEER=$O(^QA(741.2,"C",2,0)),QAOSMGMT=$O(^QA(741.2,"C",3,0)),QAOSCMTE=$O(^QA(741.2,"C",4,0)) K ^TMP($J,"QAOSPTR")
F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"AD",0,QAOSD0)) Q:QAOSD0'>0 D:$D(^QA(741,QAOSD0,"REVR","B",QAOSCLIN)) LOOP1
U IO D ^QAOSPTR1
EXIT ;
W ! D ^%ZISC
K %ZIS,ACTION,COUNT,DATE,FIND,HEAD2,LEVEL,LOC,PAGE,PAT,POP,PT,QAOSCLIN,QAOSCMTE,QAOSD0,QAOSD1,QAOSD2,QAOSDT,QAOSMGMT,QAOSPEER,QAOSQUIT,QAOSREVR,QAOSRVW,QAOSZERO,REVR,SCRN,SERV,SRV,SSN,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,^TMP($J,"QAOSPTR")
K %DT,D,DI,DIC,DQ,I,TYPE,Y,Z D K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"
Q
LOOP1 ;
S QAOSQUIT=0,QAOSZERO=^QA(741,QAOSD0,0),SCRN=+$G(^("SCRN")),PAT=$S($D(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO),SSN=$P(PAT,"^",9),PAT=$P(PAT,"^"),SCRN=$S($D(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN)
S SERV=$P(QAOSZERO,"^",6),SERV=$S(SERV="":"~UNKNOWN",$D(^DIC(49,SERV,0))#2:$P(^(0),"^"),1:"~UNKNOWN"),DATE=$P(QAOSZERO,"^",3)
Q:(DATE<QAQNBEG)!(DATE>QAQNEND)
S ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE)=SSN
F QAOSREVR=QAOSCLIN,QAOSPEER,QAOSMGMT Q:QAOSQUIT S COUNT=1 I $D(^QA(741,QAOSD0,"REVR","B",QAOSREVR)) F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSREVR,QAOSD1)) Q:QAOSD1'>0!QAOSQUIT D REVRLOOP
Q:QAOSQUIT S COUNT=1 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE",QAOSD1)) Q:QAOSD1'>0 D CMTELOOP
Q
REVRLOOP ;
S QAOSRVW=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),FIND=$P(QAOSRVW,"^",5),FIND=$S(FIND'>0:"",$D(^QA(741.6,FIND,0))#2:$P(^(0),"^",2),1:"")
I FIND="",QAOSREVR=QAOSCLIN K ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE) S QAOSQUIT=1 Q
S QAOSD2=$O(^QA(741,QAOSD0,"REVR",QAOSD1,2,0)),ACTION=$S(QAOSD2'>0:"",$D(^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2,0))#2:+^(0),1:""),ACTION=$S(ACTION'>0:"",$D(^QA(741.7,ACTION,0))#2:$P(^(0),"^",3),1:"")
S X=$S(QAOSREVR=QAOSMGMT:ACTION,1:FIND) S:X]"" ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSREVR,COUNT)=X,COUNT=COUNT+1
Q
CMTELOOP ;
S QAOSRVW=$G(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),FIND=$P(QAOSRVW,"^",2),FIND=$S(FIND'>0:"",$D(^QA(741.6,FIND,0))#2:$P(^(0),"^",2),1:"")
S:FIND]"" ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSCMTE,COUNT)=FIND,COUNT=COUNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPTR0 2418 printed Apr 09, 2024@21:23:13 Page 2
QAOSPTR0 ;HISC/DAD-REVIEW LEVEL TRACKING REPORT ;10/19/92 15:24
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 DO ^QAQDATE
if QAQQUIT
GOTO EXIT
+3 KILL %ZIS
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTDESC="Review level tracking report"
SET ZTRTN="ENTSK^QAOSPTR0"
SET ZTSAVE("QAQ*")=""
DO ^%ZTLOAD
GOTO EXIT
ENTSK ;
+1 SET QAOSCLIN=$ORDER(^QA(741.2,"C",1,0))
SET QAOSPEER=$ORDER(^QA(741.2,"C",2,0))
SET QAOSMGMT=$ORDER(^QA(741.2,"C",3,0))
SET QAOSCMTE=$ORDER(^QA(741.2,"C",4,0))
KILL ^TMP($JOB,"QAOSPTR")
+2 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741,"AD",0,QAOSD0))
if QAOSD0'>0
QUIT
if $DATA(^QA(741,QAOSD0,"REVR","B",QAOSCLIN))
DO LOOP1
+3 USE IO
DO ^QAOSPTR1
EXIT ;
+1 WRITE !
DO ^%ZISC
+2 KILL %ZIS,ACTION,COUNT,DATE,FIND,HEAD2,LEVEL,LOC,PAGE,PAT,POP,PT,QAOSCLIN,QAOSCMTE,QAOSD0,QAOSD1,QAOSD2,QAOSDT,QAOSMGMT,QAOSPEER,QAOSQUIT,QAOSREVR,QAOSRVW,QAOSZERO,REVR,SCRN,SERV,SRV,SSN,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,^TMP($JOB,"QAOSPTR")
+3 KILL %DT,D,DI,DIC,DQ,I,TYPE,Y,Z
DO K^QAQDATE
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
LOOP1 ;
+1 SET QAOSQUIT=0
SET QAOSZERO=^QA(741,QAOSD0,0)
SET SCRN=+$GET(^("SCRN"))
SET PAT=$SELECT($DATA(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO)
SET SSN=$PIECE(PAT,"^",9)
SET PAT=$PIECE(PAT,"^")
SET SCRN=$SELECT($DATA(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN)
+2 SET SERV=$PIECE(QAOSZERO,"^",6)
SET SERV=$SELECT(SERV="":"~UNKNOWN",$DATA(^DIC(49,SERV,0))#2:$PIECE(^(0),"^"),1:"~UNKNOWN")
SET DATE=$PIECE(QAOSZERO,"^",3)
+3 if (DATE<QAQNBEG)!(DATE>QAQNEND)
QUIT
+4 SET ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE)=SSN
+5 FOR QAOSREVR=QAOSCLIN,QAOSPEER,QAOSMGMT
if QAOSQUIT
QUIT
SET COUNT=1
IF $DATA(^QA(741,QAOSD0,"REVR","B",QAOSREVR))
FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSREVR,QAOSD1))
if QAOSD1'>0!QAOSQUIT
QUIT
DO REVRLOOP
+6 if QAOSQUIT
QUIT
SET COUNT=1
FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"CMTE",QAOSD1))
if QAOSD1'>0
QUIT
DO CMTELOOP
+7 QUIT
REVRLOOP ;
+1 SET QAOSRVW=$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
SET FIND=$PIECE(QAOSRVW,"^",5)
SET FIND=$SELECT(FIND'>0:"",$DATA(^QA(741.6,FIND,0))#2:$PIECE(^(0),"^",2),1:"")
+2 IF FIND=""
IF QAOSREVR=QAOSCLIN
KILL ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE)
SET QAOSQUIT=1
QUIT
+3 SET QAOSD2=$ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,2,0))
SET ACTION=$SELECT(QAOSD2'>0:"",$DATA(^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2,0))#2:+^(0),1:"")
SET ACTION=$SELECT(ACTION'>0:"",$DATA(^QA(741.7,ACTION,0))#2:$PIECE(^(0),"^",3),1:"")
+4 SET X=$SELECT(QAOSREVR=QAOSMGMT:ACTION,1:FIND)
if X]""
SET ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSREVR,COUNT)=X
SET COUNT=COUNT+1
+5 QUIT
CMTELOOP ;
+1 SET QAOSRVW=$GET(^QA(741,QAOSD0,"CMTE",QAOSD1,0))
SET FIND=$PIECE(QAOSRVW,"^",2)
SET FIND=$SELECT(FIND'>0:"",$DATA(^QA(741.6,FIND,0))#2:$PIECE(^(0),"^",2),1:"")
+2 if FIND]""
SET ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSCMTE,COUNT)=FIND
SET COUNT=COUNT+1
+3 QUIT
