QAOSPRS2 ;HISC/DAD,JCW-REVIEW SUMMARY REPORT ;11/12/92 15:43
;;3.0;Occurrence Screen;;09/14/1993
SETUP ; INITIALIZE ARRAYS
D KILLTMP
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)),QAOSRV=$P(^DD(42,.03,0),"^",3)_"^:UNKNOWN;"
F QAOSREVR="OCCR","EXCP","DELT","RECR","SEVR","CLIN","PEER","MGMT","CMTE" F QAOSTYPE=1:1:$L(QAOSLIST) S QAOTOTAL(QAOSREVR,$E(QAOSLIST,QAOSTYPE))=0
F QAOSD0=0:0 S QAOSD0=$O(^QA(741.6,QAOSD0)) Q:QAOSD0'>0 S QAOSZERO=^QA(741.6,QAOSD0,0) I +QAOSZERO'=3 F QAOSTYPE=1:1:$L(QAOSLIST) D
. S QAOSTYPE(0)=$E(QAOSLIST,QAOSTYPE),X=$P(QAOSZERO,"^",3)
. I X["1" S ^TMP($J,QAOSTYPE(0),"CLIN",+QAOSZERO)=""
. I X["2" S ^TMP($J,QAOSTYPE(0),"PEER",+QAOSZERO)=""
. Q
F QAOSD0=0:0 S QAOSD0=$O(^QA(741.7,QAOSD0)) Q:QAOSD0'>0 S QAOSZERO=^QA(741.7,QAOSD0,0) I $P(QAOSZERO,"^",2)["3" F QAOSTYPE=1:1:$L(QAOSLIST) S QAOSTYPE(0)=$E(QAOSLIST,QAOSTYPE),^TMP($J,QAOSTYPE(0),"MGMT",+QAOSZERO)=""
F QAOSD0=0:0 S QAOSD0=$O(^QA(741.8,QAOSD0)) Q:QAOSD0'>0 S QAOSEVER=+^QA(741.8,QAOSD0,0) F QAOSTYPE=1:1:$L(QAOSLIST) S QAOSTYPE(0)=$E(QAOSLIST,QAOSTYPE),^TMP($J,QAOSTYPE(0),"SEVR",QAOSEVER)=""
F QAOSCONF=1:1:4 F QAOSTYPE=1:1:$L(QAOSLIST) S QAOSTYPE(0)=$E(QAOSLIST,QAOSTYPE),^TMP($J,QAOSTYPE(0),"CMTE",QAOSCONF)=""
Q
KILLTMP ; CLEANUP ^TMP
N I,J
F I="1","L","N" F J="CLIN","PEER","MGMT","SEVR","CMTE" K ^TMP($J,I,J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPRS2 1395 printed Oct 16, 2024@18:22:28 Page 2
QAOSPRS2 ;HISC/DAD,JCW-REVIEW SUMMARY REPORT ;11/12/92 15:43
+1 ;;3.0;Occurrence Screen;;09/14/1993
SETUP ; INITIALIZE ARRAYS
+1 DO KILLTMP
+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 QAOSRV=$PIECE(^DD(42,.03,0),"^",3)_"^:UNKNOWN;"
+3 FOR QAOSREVR="OCCR","EXCP","DELT","RECR","SEVR","CLIN","PEER","MGMT","CMTE"
FOR QAOSTYPE=1:1:$LENGTH(QAOSLIST)
SET QAOTOTAL(QAOSREVR,$EXTRACT(QAOSLIST,QAOSTYPE))=0
+4 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741.6,QAOSD0))
if QAOSD0'>0
QUIT
SET QAOSZERO=^QA(741.6,QAOSD0,0)
IF +QAOSZERO'=3
FOR QAOSTYPE=1:1:$LENGTH(QAOSLIST)
Begin DoDot:1
+5 SET QAOSTYPE(0)=$EXTRACT(QAOSLIST,QAOSTYPE)
SET X=$PIECE(QAOSZERO,"^",3)
+6 IF X["1"
SET ^TMP($JOB,QAOSTYPE(0),"CLIN",+QAOSZERO)=""
+7 IF X["2"
SET ^TMP($JOB,QAOSTYPE(0),"PEER",+QAOSZERO)=""
+8 QUIT
End DoDot:1
+9 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741.7,QAOSD0))
if QAOSD0'>0
QUIT
SET QAOSZERO=^QA(741.7,QAOSD0,0)
IF $PIECE(QAOSZERO,"^",2)["3"
FOR QAOSTYPE=1:1:$LENGTH(QAOSLIST)
SET QAOSTYPE(0)=$EXTRACT(QAOSLIST,QAOSTYPE)
SET ^TMP($JOB,QAOSTYPE(0),"MGMT",+QAOSZERO)=""
+10 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741.8,QAOSD0))
if QAOSD0'>0
QUIT
SET QAOSEVER=+^QA(741.8,QAOSD0,0)
FOR QAOSTYPE=1:1:$LENGTH(QAOSLIST)
SET QAOSTYPE(0)=$EXTRACT(QAOSLIST,QAOSTYPE)
SET ^TMP($JOB,QAOSTYPE(0),"SEVR",QAOSEVER)=""
+11 FOR QAOSCONF=1:1:4
FOR QAOSTYPE=1:1:$LENGTH(QAOSLIST)
SET QAOSTYPE(0)=$EXTRACT(QAOSLIST,QAOSTYPE)
SET ^TMP($JOB,QAOSTYPE(0),"CMTE",QAOSCONF)=""
+12 QUIT
KILLTMP ; CLEANUP ^TMP
+1 NEW I,J
+2 FOR I="1","L","N"
FOR J="CLIN","PEER","MGMT","SEVR","CMTE"
KILL ^TMP($JOB,I,J)
+3 QUIT
