QAOSPDQ0 ;HISC/DAD-DELINQUENT REVIEWS REPORT ;10/19/92 15:03
;;3.0;Occurrence Screen;;09/14/1993
D ^QAQDATE G:QAQQUIT EXIT
ASK W !,"Include reviews that were completed after the due date" S %=2 D YN^DICN S QAOSLATE=$S(%=1:1,1:0) G:%=-1 EXIT
I '% W !!?5,"Enter Y(es) to include those peer and management reviews that",!?5,"were done, but were completed after the due dates.",!?5,"Enter N(o) to include only those reviews requested, but not",!?5,"yet completed.",! G ASK
K %ZIS S %ZIS="QM" W ! D ^%ZIS G:POP EXIT I $D(IO("Q")) S ZTDESC="Delinquent reviews report",ZTRTN="ENTSK^QAOSPDQ0",ZTSAVE("QAOSLATE")="",ZTSAVE("QAQ*")="" D ^%ZTLOAD G EXIT
ENTSK ;
K ^TMP($J,"QAOSPDQ")
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)),QAOSREFP="^"_$O(^QA(741.7,"B",2,0))_"^",QAOSREFM="^" F QA=3,5,6,7 S QAOSREFM=QAOSREFM_$O(^QA(741.7,"B",QA,0))_"^"
F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"AD",0,QAOSD0)) Q:QAOSD0'>0 D LOOP1
U IO D ^QAOSPDQ1
EXIT ;
W ! D ^%ZISC
K %,%DT,%ZIS,DIR,PAGE,POP,QA,QAOS,QAOSACTN,QAOSCLIN,QAOSD0,QAOSD1,QAOSDATE,QAOSDONE,QAOSDT,QAOSLATE,QAOSM,QAOSMDUE,QAOSMGMT,QAOSNAME,QAOSP,QAOSPDUE,QAOSPEER,QAOSQUIT,QAOSREFM,QAOSREFP,QAOSS1,QAOSSCRN,QAOSSERV,QAOSSN,QAOSSUB
K QAOSZERO,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,ZTSAVE,^TMP($J,"QAOSPDQ")
D K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"
Q
LOOP1 ;
S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:QAOSZERO="" S QAOSSCRN=+$G(^("SCRN")) Q:QAOSSCRN'>0
S Y=$P(QAOSZERO,"^",3) Q:(Y<QAQNBEG)!(Y>QAQNEND)
S QAOSPDUE=$P(QAOSZERO,"^",12),QAOSMDUE=$P(QAOSZERO,"^",13) Q:(QAOSPDUE="")!(QAOSMDUE="")
S QAOS=$S($D(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO),QAOSNAME=$P(QAOS,"^"),QAOSSN=$P(QAOS,"^",9),QAOSSCRN=$S($D(^QA(741.1,QAOSSCRN,0))#2:$P(^(0),"^"),1:QAOSSCRN)
S QAOSDATE=+$P(QAOSZERO,"^",3),QAOSSERV=+$P(QAOSZERO,"^",6),QAOSSERV=$S($D(^DIC(49,QAOSSERV,0))#2:$P(^(0),"^"),1:"~UNKNOWN")
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,QAOSD1)) Q:QAOSD1'>0 F QAOSACTN=2:1:$L(QAOSREFP,"^")-1 I $O(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSACTN,0)) D CHKPEER
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1)) Q:QAOSD1'>0 F QAOSACTN=2:1:$L(QAOSREFM,"^")-1 I $O(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSACTN,0)) D CHKMGMT
Q
CHKPEER ;
S QAOSSUB="P",QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0)) I QAOSS1'>0 D CHKP Q
F QAOSS1=0:0 S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSS1)) Q:QAOSS1'>0 D CHKP
Q
CHKP S QAOSDONE=$P($G(^QA(741,QAOSD0,"REVR",+QAOSS1,0)),"^",3)
I DT>QAOSPDUE,QAOSDONE'>0 D SET
I QAOSLATE,QAOSDONE>QAOSPDUE D SET
Q
CHKMGMT ;
S QAOSSUB="M",QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,0)) I QAOSS1'>0 D CHKM Q
F QAOSS1=0:0 S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSS1)) Q:QAOSS1'>0 D CHKM
Q
CHKM S QAOSDONE=$P($G(^QA(741,QAOSD0,"REVR",+QAOSS1,0)),"^",3)
I DT>QAOSMDUE,QAOSDONE'>0 D SET
I QAOSLATE,QAOSDONE>QAOSMDUE D SET
Q
SET ;
S ^TMP($J,"QAOSPDQ",QAOSSERV,QAOSNAME,QAOSDATE)=QAOSSCRN_"^"_QAOSSN_"^"_QAOSPDUE_"^"_QAOSMDUE,^(QAOSDATE,QAOSSUB,$S(QAOSS1:QAOSS1,1:1))=QAOSDONE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPDQ0 3068 printed Nov 22, 2024@17:31:41 Page 2
QAOSPDQ0 ;HISC/DAD-DELINQUENT REVIEWS REPORT ;10/19/92 15:03
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 DO ^QAQDATE
if QAQQUIT
GOTO EXIT
ASK WRITE !,"Include reviews that were completed after the due date"
SET %=2
DO YN^DICN
SET QAOSLATE=$SELECT(%=1:1,1:0)
if %=-1
GOTO EXIT
+1 IF '%
WRITE !!?5,"Enter Y(es) to include those peer and management reviews that",!?5,"were done, but were completed after the due dates.",!?5,"Enter N(o) to include only those reviews requested, but not",!?5,"yet completed.",!
GOTO ASK
+2 KILL %ZIS
SET %ZIS="QM"
WRITE !
DO ^%ZIS
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTDESC="Delinquent reviews report"
SET ZTRTN="ENTSK^QAOSPDQ0"
SET ZTSAVE("QAOSLATE")=""
SET ZTSAVE("QAQ*")=""
DO ^%ZTLOAD
GOTO EXIT
ENTSK ;
+1 KILL ^TMP($JOB,"QAOSPDQ")
+2 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 QAOSREFP="^"_$ORDER(^QA(741.7,"B",2,0))_"^"
SET QAOSREFM="^"
FOR QA=3,5,6,7
SET QAOSREFM=QAOSREFM_$ORDER(^QA(741.7,"B",QA,0))_"^"
+3 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741,"AD",0,QAOSD0))
if QAOSD0'>0
QUIT
DO LOOP1
+4 USE IO
DO ^QAOSPDQ1
EXIT ;
+1 WRITE !
DO ^%ZISC
+2 KILL %,%DT,%ZIS,DIR,PAGE,POP,QA,QAOS,QAOSACTN,QAOSCLIN,QAOSD0,QAOSD1,QAOSDATE,QAOSDONE,QAOSDT,QAOSLATE,QAOSM,QAOSMDUE,QAOSMGMT,QAOSNAME,QAOSP,QAOSPDUE,QAOSPEER,QAOSQUIT,QAOSREFM,QAOSREFP,QAOSS1,QAOSSCRN,QAOSSERV,QAOSSN,QAOSSUB
+3 KILL QAOSZERO,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,ZTSAVE,^TMP($JOB,"QAOSPDQ")
+4 DO K^QAQDATE
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
LOOP1 ;
+1 SET QAOSZERO=$GET(^QA(741,QAOSD0,0))
if QAOSZERO=""
QUIT
SET QAOSSCRN=+$GET(^("SCRN"))
if QAOSSCRN'>0
QUIT
+2 SET Y=$PIECE(QAOSZERO,"^",3)
if (Y<QAQNBEG)!(Y>QAQNEND)
QUIT
+3 SET QAOSPDUE=$PIECE(QAOSZERO,"^",12)
SET QAOSMDUE=$PIECE(QAOSZERO,"^",13)
if (QAOSPDUE="")!(QAOSMDUE="")
QUIT
+4 SET QAOS=$SELECT($DATA(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO)
SET QAOSNAME=$PIECE(QAOS,"^")
SET QAOSSN=$PIECE(QAOS,"^",9)
SET QAOSSCRN=$SELECT($DATA(^QA(741.1,QAOSSCRN,0))#2:$PIECE(^(0),"^"),1:QAOSSCRN)
+5 SET QAOSDATE=+$PIECE(QAOSZERO,"^",3)
SET QAOSSERV=+$PIECE(QAOSZERO,"^",6)
SET QAOSSERV=$SELECT($DATA(^DIC(49,QAOSSERV,0))#2:$PIECE(^(0),"^"),1:"~UNKNOWN")
+6 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,QAOSD1))
if QAOSD1'>0
QUIT
FOR QAOSACTN=2:1:$LENGTH(QAOSREFP,"^")-1
IF $ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSACTN,0))
DO CHKPEER
+7 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1))
if QAOSD1'>0
QUIT
FOR QAOSACTN=2:1:$LENGTH(QAOSREFM,"^")-1
IF $ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSACTN,0))
DO CHKMGMT
+8 QUIT
CHKPEER ;
+1 SET QAOSSUB="P"
SET QAOSS1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0))
IF QAOSS1'>0
DO CHKP
QUIT
+2 FOR QAOSS1=0:0
SET QAOSS1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSS1))
if QAOSS1'>0
QUIT
DO CHKP
+3 QUIT
CHKP SET QAOSDONE=$PIECE($GET(^QA(741,QAOSD0,"REVR",+QAOSS1,0)),"^",3)
+1 IF DT>QAOSPDUE
IF QAOSDONE'>0
DO SET
+2 IF QAOSLATE
IF QAOSDONE>QAOSPDUE
DO SET
+3 QUIT
CHKMGMT ;
+1 SET QAOSSUB="M"
SET QAOSS1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,0))
IF QAOSS1'>0
DO CHKM
QUIT
+2 FOR QAOSS1=0:0
SET QAOSS1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSS1))
if QAOSS1'>0
QUIT
DO CHKM
+3 QUIT
CHKM SET QAOSDONE=$PIECE($GET(^QA(741,QAOSD0,"REVR",+QAOSS1,0)),"^",3)
+1 IF DT>QAOSMDUE
IF QAOSDONE'>0
DO SET
+2 IF QAOSLATE
IF QAOSDONE>QAOSMDUE
DO SET
+3 QUIT
SET ;
+1 SET ^TMP($JOB,"QAOSPDQ",QAOSSERV,QAOSNAME,QAOSDATE)=QAOSSCRN_"^"_QAOSSN_"^"_QAOSPDUE_"^"_QAOSMDUE
SET ^(QAOSDATE,QAOSSUB,$SELECT(QAOSS1:QAOSS1,1:1))=QAOSDONE
+2 QUIT
