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