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