- 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 Mar 13, 2025@21:26:39 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
