QAOSPRS0 ;HISC/DAD,JCW-REVIEW SUMMARY REPORT ;4/30/93 09:26
;;3.0;Occurrence Screen;;09/14/1993
K DIR S DIR(0)="LO^1:3^K:X[""."" X",DIR("A")="Select screen criteria to include",DIR("B")=1
S DIR("?",1)="Choose from:",DIR("?",2)=" 1 National",DIR("?",3)=" 2 Local",DIR("?",4)=" 3 Inactive",DIR("?")="Select any combination of the codes listed above, e.g. 1-3, 1,2"
W ! D ^DIR G:$D(DIRUT) EXIT S QAOSLIST=$TR(Y,"123,","NL1")
W !!,"Select the reporting period:" D ^QAQDATE G:QAQQUIT EXIT
W !,"NOTE: This is a 132 column report."
DEVICE ;
K %ZIS S %ZIS="QM",%ZIS("B")="" W ! D ^%ZIS G:POP EXIT
I $D(IOM)#2,IOM<132 D ^%ZISC W !?5,"*** Please choose a 132 column output device !! ***",*7 G DEVICE
I $D(IO("Q")) K IO("Q") S ZTRTN="ENTSK^QAOSPRS0",(ZTSAVE("QAQ*"),ZTSAVE("QAO*"))="",ZTDESC="Occurrence Screen Review Summary Report" D ^%ZTLOAD G EXIT
ENTSK ;
D SETUP^QAOSPRS2
F QAOSDT=QAQNBEG-.0000001:0 S QAOSDT=$O(^QA(741,"C",QAOSDT)) Q:(QAOSDT'>0)!(QAOSDT>(QAQNEND+.24)) F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDT,QAOSD0)) Q:QAOSD0'>0 D LOOP
U IO D ^QAOSPRS1
EXIT ;
D ^%ZISC
K %DT,%ZIS,DIR,DIRUT,POP,QA,QAOSACTN,QAOSCLIN,QAOSCONF,QAOSD0,QAOSD1,QAOSD2,QAOSDD,QAOSDT,QAOSEVER,QAOSFIND,QAOSHOSP,QAOSIEN,QAOSLIST,QAOSMGMT,QAOSNUM,QAOSPAGE,QAOSPEER,QAOSQOCS,QAOSQUIT,QAOSREVR,QAOSRV,QAOSRVNO
K QAOSSCRN,QAOSSERV,QAOSSEVR,QAOSTEXT,QAOSTYPE,QAOSWARD,QAOSZERO,QAOTODAY,QAOTOTAL,TAB,TOT,UNDL1,UNDL2,X,Y,ZTDESC,ZTRTN,ZTSAVE
D KILLTMP^QAOSPRS2,K^QAQDATE
S:$D(ZTQUEUED) ZTREQ="@"
Q
LOOP ;
S QAOSZERO=$G(^QA(741,QAOSD0,0)),QAOSSCRN=+$G(^("SCRN"))
S QAOSTYPE=$P($G(^QA(741.1,QAOSSCRN,0)),"^",4) Q:(QAOSTYPE="")!(QAOSLIST'[QAOSTYPE)
S QAOTOTAL("RECR",QAOSTYPE)=QAOTOTAL("RECR",QAOSTYPE)+1
I $P(QAOSZERO,"^",11)=2 S QAOTOTAL("DELT",QAOSTYPE)=QAOTOTAL("DELT",QAOSTYPE)+1 Q
S QAOSHOSP=+$P(QAOSZERO,"^",5)
S QAOSHOSP(0)=$G(^SC(QAOSHOSP,0))
I $P(QAOSHOSP(0),"^",3)="C" D
. S QAOSSERV=$P(QAOSHOSP(0),"^",8)
. S:QAOSSERV="N" QAOSSERV="NE"
. S:QAOSSERV="0" QAOSSERV=""
. Q
E D
. S QAOSWARD=+$G(^SC(QAOSHOSP,42))
. S QAOSSERV=$P($G(^DIC(42,QAOSWARD,0)),"^",3)
. Q
S:QAOSSERV="" QAOSSERV="^"
S QAOSRVNO=$P("4^11^8^6^5^3^9^10^2^1^7^12","^",$L($P(QAOSRV,QAOSSERV),";"))
CLIN ;
S QAOSFIND=""
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,QAOSD1)) Q:(QAOSD1'>0)!(QAOSFIND=3) D
. S QAOSFIND=+$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
. S QAOSFIND=+$G(^QA(741.6,QAOSFIND,0)) Q:(QAOSFIND'>0)!(QAOSFIND=3)
. S ^TMP($J,QAOSTYPE,"CLIN",QAOSFIND)=$G(^TMP($J,QAOSTYPE,"CLIN",QAOSFIND))+1
. S QAOTOTAL("CLIN",QAOSTYPE)=QAOTOTAL("CLIN",QAOSTYPE)+1
. Q
I QAOSFIND=3 S QAOTOTAL("EXCP",QAOSTYPE)=QAOTOTAL("EXCP",QAOSTYPE)+1 Q
S QAOTOTAL("OCCR",QAOSTYPE)=QAOTOTAL("OCCR",QAOSTYPE)+1
PEER ;
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1)) Q:QAOSD1'>0 D
. S QA=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
. Q:$P(QA,"^",9)'>0
. S QAOSFIND=+$P(QA,"^",5),QAOSFIND=+$G(^QA(741.6,QAOSFIND,0))
. Q:QAOSFIND'>0
. S $P(^TMP($J,QAOSTYPE,"PEER",QAOSFIND),"^",QAOSRVNO)=$P($G(^TMP($J,QAOSTYPE,"PEER",QAOSFIND)),"^",QAOSRVNO)+1
. S QAOTOTAL("PEER",QAOSTYPE)=QAOTOTAL("PEER",QAOSTYPE)+1
. Q
MGMT ;
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSD1)) Q:QAOSD1'>0 F QAOSD2=0:0 S QAOSD2=$O(^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2)) Q:QAOSD2'>0 D
. S QAOSACTN=+^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2,0)
. S QAOSACTN=+$G(^QA(741.7,QAOSACTN,0)) Q:QAOSACTN'>0
. S $P(^TMP($J,QAOSTYPE,"MGMT",QAOSACTN),"^",QAOSRVNO)=$P($G(^TMP($J,QAOSTYPE,"MGMT",QAOSACTN)),"^",QAOSRVNO)+1
. S QAOTOTAL("MGMT",QAOSTYPE)=QAOTOTAL("MGMT",QAOSTYPE)+1
. Q
SEVER ;
S QAOSEVER=+$P(QAOSZERO,"^",18),QAOSEVER=$G(^QA(741.8,QAOSEVER,0))
I QAOSEVER]"" D
. S ^TMP($J,QAOSTYPE,"SEVR",+QAOSEVER)=$G(^TMP($J,QAOSTYPE,"SEVR",+QAOSEVER))+1
. S QAOTOTAL("SEVR",QAOSTYPE)=QAOTOTAL("SEVR",QAOSTYPE)+1
. Q
CMTE ;
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE",QAOSD1)) Q:QAOSD1'>0 D
. S QAOSCONF=$P($G(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",5)
. Q:QAOSCONF'>0
. S ^TMP($J,QAOSTYPE,"CMTE",QAOSCONF)=$G(^TMP($J,QAOSTYPE,"CMTE",QAOSCONF))+1
. S QAOTOTAL("CMTE",QAOSTYPE)=QAOTOTAL("CMTE",QAOSTYPE)+1
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPRS0 4203 printed Dec 13, 2024@02:21:50 Page 2
QAOSPRS0 ;HISC/DAD,JCW-REVIEW SUMMARY REPORT ;4/30/93 09:26
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 KILL DIR
SET DIR(0)="LO^1:3^K:X[""."" X"
SET DIR("A")="Select screen criteria to include"
SET DIR("B")=1
+3 SET DIR("?",1)="Choose from:"
SET DIR("?",2)=" 1 National"
SET DIR("?",3)=" 2 Local"
SET DIR("?",4)=" 3 Inactive"
SET DIR("?")="Select any combination of the codes listed above, e.g. 1-3, 1,2"
+4 WRITE !
DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
SET QAOSLIST=$TRANSLATE(Y,"123,","NL1")
+5 WRITE !!,"Select the reporting period:"
DO ^QAQDATE
if QAQQUIT
GOTO EXIT
+6 WRITE !,"NOTE: This is a 132 column report."
DEVICE ;
+1 KILL %ZIS
SET %ZIS="QM"
SET %ZIS("B")=""
WRITE !
DO ^%ZIS
if POP
GOTO EXIT
+2 IF $DATA(IOM)#2
IF IOM<132
DO ^%ZISC
WRITE !?5,"*** Please choose a 132 column output device !! ***",*7
GOTO DEVICE
+3 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="ENTSK^QAOSPRS0"
SET (ZTSAVE("QAQ*"),ZTSAVE("QAO*"))=""
SET ZTDESC="Occurrence Screen Review Summary Report"
DO ^%ZTLOAD
GOTO EXIT
ENTSK ;
+1 DO SETUP^QAOSPRS2
+2 FOR QAOSDT=QAQNBEG-.0000001:0
SET QAOSDT=$ORDER(^QA(741,"C",QAOSDT))
if (QAOSDT'>0)!(QAOSDT>(QAQNEND+.24))
QUIT
FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741,"C",QAOSDT,QAOSD0))
if QAOSD0'>0
QUIT
DO LOOP
+3 USE IO
DO ^QAOSPRS1
EXIT ;
+1 DO ^%ZISC
+2 KILL %DT,%ZIS,DIR,DIRUT,POP,QA,QAOSACTN,QAOSCLIN,QAOSCONF,QAOSD0,QAOSD1,QAOSD2,QAOSDD,QAOSDT,QAOSEVER,QAOSFIND,QAOSHOSP,QAOSIEN,QAOSLIST,QAOSMGMT,QAOSNUM,QAOSPAGE,QAOSPEER,QAOSQOCS,QAOSQUIT,QAOSREVR,QAOSRV,QAOSRVNO
+3 KILL QAOSSCRN,QAOSSERV,QAOSSEVR,QAOSTEXT,QAOSTYPE,QAOSWARD,QAOSZERO,QAOTODAY,QAOTOTAL,TAB,TOT,UNDL1,UNDL2,X,Y,ZTDESC,ZTRTN,ZTSAVE
+4 DO KILLTMP^QAOSPRS2
DO K^QAQDATE
+5 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
LOOP ;
+1 SET QAOSZERO=$GET(^QA(741,QAOSD0,0))
SET QAOSSCRN=+$GET(^("SCRN"))
+2 SET QAOSTYPE=$PIECE($GET(^QA(741.1,QAOSSCRN,0)),"^",4)
if (QAOSTYPE="")!(QAOSLIST'[QAOSTYPE)
QUIT
+3 SET QAOTOTAL("RECR",QAOSTYPE)=QAOTOTAL("RECR",QAOSTYPE)+1
+4 IF $PIECE(QAOSZERO,"^",11)=2
SET QAOTOTAL("DELT",QAOSTYPE)=QAOTOTAL("DELT",QAOSTYPE)+1
QUIT
+5 SET QAOSHOSP=+$PIECE(QAOSZERO,"^",5)
+6 SET QAOSHOSP(0)=$GET(^SC(QAOSHOSP,0))
+7 IF $PIECE(QAOSHOSP(0),"^",3)="C"
Begin DoDot:1
+8 SET QAOSSERV=$PIECE(QAOSHOSP(0),"^",8)
+9 if QAOSSERV="N"
SET QAOSSERV="NE"
+10 if QAOSSERV="0"
SET QAOSSERV=""
+11 QUIT
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET QAOSWARD=+$GET(^SC(QAOSHOSP,42))
+14 SET QAOSSERV=$PIECE($GET(^DIC(42,QAOSWARD,0)),"^",3)
+15 QUIT
End DoDot:1
+16 if QAOSSERV=""
SET QAOSSERV="^"
+17 SET QAOSRVNO=$PIECE("4^11^8^6^5^3^9^10^2^1^7^12","^",$LENGTH($PIECE(QAOSRV,QAOSSERV),";"))
CLIN ;
+1 SET QAOSFIND=""
+2 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,QAOSD1))
if (QAOSD1'>0)!(QAOSFIND=3)
QUIT
Begin DoDot:1
+3 SET QAOSFIND=+$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
+4 SET QAOSFIND=+$GET(^QA(741.6,QAOSFIND,0))
if (QAOSFIND'>0)!(QAOSFIND=3)
QUIT
+5 SET ^TMP($JOB,QAOSTYPE,"CLIN",QAOSFIND)=$GET(^TMP($JOB,QAOSTYPE,"CLIN",QAOSFIND))+1
+6 SET QAOTOTAL("CLIN",QAOSTYPE)=QAOTOTAL("CLIN",QAOSTYPE)+1
+7 QUIT
End DoDot:1
+8 IF QAOSFIND=3
SET QAOTOTAL("EXCP",QAOSTYPE)=QAOTOTAL("EXCP",QAOSTYPE)+1
QUIT
+9 SET QAOTOTAL("OCCR",QAOSTYPE)=QAOTOTAL("OCCR",QAOSTYPE)+1
PEER ;
+1 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1))
if QAOSD1'>0
QUIT
Begin DoDot:1
+2 SET QA=$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
+3 if $PIECE(QA,"^",9)'>0
QUIT
+4 SET QAOSFIND=+$PIECE(QA,"^",5)
SET QAOSFIND=+$GET(^QA(741.6,QAOSFIND,0))
+5 if QAOSFIND'>0
QUIT
+6 SET $PIECE(^TMP($JOB,QAOSTYPE,"PEER",QAOSFIND),"^",QAOSRVNO)=$PIECE($GET(^TMP($JOB,QAOSTYPE,"PEER",QAOSFIND)),"^",QAOSRVNO)+1
+7 SET QAOTOTAL("PEER",QAOSTYPE)=QAOTOTAL("PEER",QAOSTYPE)+1
+8 QUIT
End DoDot:1
MGMT ;
+1 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSD1))
if QAOSD1'>0
QUIT
FOR QAOSD2=0:0
SET QAOSD2=$ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2))
if QAOSD2'>0
QUIT
Begin DoDot:1
+2 SET QAOSACTN=+^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2,0)
+3 SET QAOSACTN=+$GET(^QA(741.7,QAOSACTN,0))
if QAOSACTN'>0
QUIT
+4 SET $PIECE(^TMP($JOB,QAOSTYPE,"MGMT",QAOSACTN),"^",QAOSRVNO)=$PIECE($GET(^TMP($JOB,QAOSTYPE,"MGMT",QAOSACTN)),"^",QAOSRVNO)+1
+5 SET QAOTOTAL("MGMT",QAOSTYPE)=QAOTOTAL("MGMT",QAOSTYPE)+1
+6 QUIT
End DoDot:1
SEVER ;
+1 SET QAOSEVER=+$PIECE(QAOSZERO,"^",18)
SET QAOSEVER=$GET(^QA(741.8,QAOSEVER,0))
+2 IF QAOSEVER]""
Begin DoDot:1
+3 SET ^TMP($JOB,QAOSTYPE,"SEVR",+QAOSEVER)=$GET(^TMP($JOB,QAOSTYPE,"SEVR",+QAOSEVER))+1
+4 SET QAOTOTAL("SEVR",QAOSTYPE)=QAOTOTAL("SEVR",QAOSTYPE)+1
+5 QUIT
End DoDot:1
CMTE ;
+1 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"CMTE",QAOSD1))
if QAOSD1'>0
QUIT
Begin DoDot:1
+2 SET QAOSCONF=$PIECE($GET(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",5)
+3 if QAOSCONF'>0
QUIT
+4 SET ^TMP($JOB,QAOSTYPE,"CMTE",QAOSCONF)=$GET(^TMP($JOB,QAOSTYPE,"CMTE",QAOSCONF))+1
+5 SET QAOTOTAL("CMTE",QAOSTYPE)=QAOTOTAL("CMTE",QAOSTYPE)+1
+6 QUIT
End DoDot:1
+7 QUIT
