QAOSPSM0 ;HISC/DAD-SUMMARY OF OCCURRENCE SCREENING - GET DATA ;12/8/93 11:51
;;3.0;Occurrence Screen;**2,5**;09/14/1993
K ^UTILITY($J,"QAOSPSM"),^UTILITY($J,"QAOSXREF"),^UTILITY($J,"QAOSPEND")
K QAOSACTN,QAOSRV S QAOSLIST=""
F QA=1:1:$L(QAOSLIST(0),",") D
. S QAO=$P(QAOSLIST(0),",",QA)
. S QAOSLIST=QAOSLIST_$S(QAO="1":"^N",QAO=2:"^L",QAO=3:"^1",1:"^")
. Q
S (QAOSNUM("N"),QAOSNUM("L"),QAOSNUM("1"))=1
F QAOSCRN=0:0 S QAOSCRN=$O(^QA(741.1,"B",QAOSCRN)) Q:QAOSCRN'>0 D
. F QAOSD0=0:0 S QAOSD0=$O(^QA(741.1,"B",QAOSCRN,QAOSD0)) Q:QAOSD0'>0 D
.. S QAOS=$G(^QA(741.1,QAOSD0,0)),QA=$P(QAOS,"^",4)
.. Q:QAOSLIST'[("^"_QA_"^")
.. S ^UTILITY($J,"QAOSPSM",QA,QAOSNUM(QA))=+QAOS
.. S ^UTILITY($J,"QAOSXREF",+QAOS)=QAOSNUM(QA)_"^"_QA
.. S QAOSNUM(QA)=QAOSNUM(QA)+1
.. Q
. Q
S QAOSCLIN=+$O(^QA(741.2,"C",1,0)),QAOSPEER=+$O(^QA(741.2,"C",2,0))
S QAOSMGMT=+$O(^QA(741.2,"C",3,0)),QAOSRFPR=+$O(^QA(741.7,"B",2,0))
F QA=1:1:16 S QAOSFIND(QA)=+$O(^QA(741.6,"B",QA,0))
F QAOSDATE=QAQNBEG-.0000001:0 S QAOSDATE=$O(^QA(741,"C",QAOSDATE)) Q:(QAOSDATE'>0)!(QAOSDATE>(QAQNEND+.9999999)) F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDATE,QAOSD0)) Q:QAOSD0'>0 D LOOP1
Q
LOOP1 ;
S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:(QAOSZERO="")!($P(QAOSZERO,"^",11)=2)
S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN"))
S QAOSSCRN(0)=$G(^QA(741.1,QAOSSCRN,0))
S QAO=$G(^UTILITY($J,"QAOSXREF",+QAOSSCRN(0))),QAOSSEQ=+QAO
S QAOSSTAT=$P(QAO,"^",2) Q:QAOSLIST'[("^"_QAOSSTAT_"^")
S QAOSD1=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
S QAOSCREV=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
; If Exist(Peer) &' Exist(Clin) set QAOSCREV="."
I QAOSCREV="",$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0)) S QAOSCREV="."
Q:QAOSCREV="" ; NO CLIN & NO PEER
S QAOSFIND=+$P(QAOSCREV,"^",5) Q:QAOSFIND=QAOSFIND(3) ; EXCEPTION
;
; MGMT actions
K SERV S QAOSS1=0
F S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSS1)) Q:QAOSS1'>0 D
. S QA=$G(^QA(741,QAOSD0,"REVR",QAOSS1,0)),SERV=+$P(QA,"^",10)
. Q:$G(SERV(SERV)) S SERV(SERV)=1,QAOSS2=0
. F S QAOSS2=$O(^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2)) Q:QAOSS2'>0 D
.. S Y=+^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2,0),X=+$G(^QA(741.7,Y,0))
.. S QAOSACTN(QAOSSTAT,X)=$G(QAOSACTN(QAOSSTAT,X))+1
.. Q
. Q
; BED SERVICE SPECIFIC occur
S QAOSHOSP=+$P(QAOSZERO,"^",5)
S QAOSHOSP(0)=$G(^SC(QAOSHOSP,0))
I $P(QAOSHOSP(0),"^",3)="C" D
. S SERV=$P(QAOSHOSP(0),"^",8)
. S:SERV="N" SERV="NE"
. Q
E D
. S QAOSWARD=+$G(^SC(QAOSHOSP,42))
. S SERV=$P($G(^DIC(42,QAOSWARD,0)),"^",3)
. Q
S Y=+$P("^M1^NE1^S2^P3^I4^NH4^R4^SCI4^D4^B4","^"_SERV,2)
I Y D
. S X=1+$P($G(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",Y)
. S $P(QAOSRV(QAOSSTAT,QAOSSEQ),"^",Y)=X
. S X=1+$P($G(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",5)
. S $P(QAOSRV(QAOSSTAT,QAOSSEQ),"^",5)=X
. Q
S QAOSTEMP=^UTILITY($J,"QAOSPSM",QAOSSTAT,QAOSSEQ)
; # OCCUR REVIEWED CLINICALLY
I QAOSCREV'="." S $P(QAOSTEMP,"^",2)=$P(QAOSTEMP,"^",2)+1
; # OCCUR REFERRED PEER (CLIN & NO PEER FOUND)
I $O(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSRFPR,0)) D
. I $O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0))'>0 D
.. S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
.. S $P(QAOSTEMP,"^",7)=$P(QAOSTEMP,"^",7)+1 ; PEER: PENDING
.. D PEND(1)
.. Q
. Q
; OUTCOME PEER: LEVELS 1,2,3
K SERV S QAOSS1=0
F S QAOSS1=$O(^QA(741,QAOSD0,"REVR","AONLY1",1,QAOSS1)) Q:QAOSS1'>0 D
. S QA=$G(^QA(741,QAOSD0,"REVR",QAOSS1,0))
. Q:($P(QA,"^")'=QAOSPEER)!($P(QA,"^",9)'>0) ; NOT PEER ! NOT FINAL
. S QAOSLEVL=$P(QA,"^",5),SERV=+$P(QA,"^",10),SERV(SERV)=1
. S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
. I QAOSLEVL=QAOSFIND(11) S $P(QAOSTEMP,"^",4)=$P(QAOSTEMP,"^",4)+1
. I QAOSLEVL=QAOSFIND(12) S $P(QAOSTEMP,"^",5)=$P(QAOSTEMP,"^",5)+1
. I QAOSLEVL=QAOSFIND(13) S $P(QAOSTEMP,"^",6)=$P(QAOSTEMP,"^",6)+1
. Q
; OUTCOME PEER: PENDING
S QAOSS1=0
F S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSS1)) Q:QAOSS1'>0 D
. S SERV=+$P($G(^QA(741,QAOSD0,"REVR",QAOSS1,0)),"^",10)
. Q:$G(SERV(SERV)) S SERV(SERV)=1
. S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
. S $P(QAOSTEMP,"^",7)=$P(QAOSTEMP,"^",7)+1 ; PEER: PENDING
. D PEND(2)
. Q
; # OCCUR REFERRED SYS PROB
F X=5,7,8,9 I QAOSFIND=QAOSFIND(X) D Q
. S $P(QAOSTEMP,"^",8)=$P(QAOSTEMP,"^",8)+1
. Q
; # OCCUR REFERRED EQUIP PROB
F X=4,6,8,9 I QAOSFIND=QAOSFIND(X) D Q
. S $P(QAOSTEMP,"^",9)=$P(QAOSTEMP,"^",9)+1
. Q
S ^UTILITY($J,"QAOSPSM",QAOSSTAT,QAOSSEQ)=QAOSTEMP
Q
PEND(Y) ; SAVE PENDING , PENDING TYPE (Y=1/2)
S QAOSDPT=$G(^DPT(+QAOSZERO,0)),QAOSSN=$P(QAOSDPT,"^",9)
S QAOSPAT=$S($P(QAOSDPT,"^")]"":$P(QAOSDPT,"^"),1:+QAOSZERO)
S QAOSDATE=+$P(QAOSZERO,"^",3),X=QAOSSN_"^"_Y
S ^UTILITY($J,"QAOSPEND",QAOSSCRN,QAOSDATE,QAOSPAT,QAOSD0)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPSM0 4805 printed Nov 22, 2024@17:31:53 Page 2
QAOSPSM0 ;HISC/DAD-SUMMARY OF OCCURRENCE SCREENING - GET DATA ;12/8/93 11:51
+1 ;;3.0;Occurrence Screen;**2,5**;09/14/1993
+2 KILL ^UTILITY($JOB,"QAOSPSM"),^UTILITY($JOB,"QAOSXREF"),^UTILITY($JOB,"QAOSPEND")
+3 KILL QAOSACTN,QAOSRV
SET QAOSLIST=""
+4 FOR QA=1:1:$LENGTH(QAOSLIST(0),",")
Begin DoDot:1
+5 SET QAO=$PIECE(QAOSLIST(0),",",QA)
+6 SET QAOSLIST=QAOSLIST_$SELECT(QAO="1":"^N",QAO=2:"^L",QAO=3:"^1",1:"^")
+7 QUIT
End DoDot:1
+8 SET (QAOSNUM("N"),QAOSNUM("L"),QAOSNUM("1"))=1
+9 FOR QAOSCRN=0:0
SET QAOSCRN=$ORDER(^QA(741.1,"B",QAOSCRN))
if QAOSCRN'>0
QUIT
Begin DoDot:1
+10 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741.1,"B",QAOSCRN,QAOSD0))
if QAOSD0'>0
QUIT
Begin DoDot:2
+11 SET QAOS=$GET(^QA(741.1,QAOSD0,0))
SET QA=$PIECE(QAOS,"^",4)
+12 if QAOSLIST'[("^"_QA_"^")
QUIT
+13 SET ^UTILITY($JOB,"QAOSPSM",QA,QAOSNUM(QA))=+QAOS
+14 SET ^UTILITY($JOB,"QAOSXREF",+QAOS)=QAOSNUM(QA)_"^"_QA
+15 SET QAOSNUM(QA)=QAOSNUM(QA)+1
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 SET QAOSCLIN=+$ORDER(^QA(741.2,"C",1,0))
SET QAOSPEER=+$ORDER(^QA(741.2,"C",2,0))
+19 SET QAOSMGMT=+$ORDER(^QA(741.2,"C",3,0))
SET QAOSRFPR=+$ORDER(^QA(741.7,"B",2,0))
+20 FOR QA=1:1:16
SET QAOSFIND(QA)=+$ORDER(^QA(741.6,"B",QA,0))
+21 FOR QAOSDATE=QAQNBEG-.0000001:0
SET QAOSDATE=$ORDER(^QA(741,"C",QAOSDATE))
if (QAOSDATE'>0)!(QAOSDATE>(QAQNEND+.9999999))
QUIT
FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741,"C",QAOSDATE,QAOSD0))
if QAOSD0'>0
QUIT
DO LOOP1
+22 QUIT
LOOP1 ;
+1 SET QAOSZERO=$GET(^QA(741,QAOSD0,0))
if (QAOSZERO="")!($PIECE(QAOSZERO,"^",11)=2)
QUIT
+2 SET QAOSSCRN=+$GET(^QA(741,QAOSD0,"SCRN"))
+3 SET QAOSSCRN(0)=$GET(^QA(741.1,QAOSSCRN,0))
+4 SET QAO=$GET(^UTILITY($JOB,"QAOSXREF",+QAOSSCRN(0)))
SET QAOSSEQ=+QAO
+5 SET QAOSSTAT=$PIECE(QAO,"^",2)
if QAOSLIST'[("^"_QAOSSTAT_"^")
QUIT
+6 SET QAOSD1=+$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
+7 SET QAOSCREV=$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
+8 ; If Exist(Peer) &' Exist(Clin) set QAOSCREV="."
+9 IF QAOSCREV=""
IF $ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0))
SET QAOSCREV="."
+10 ; NO CLIN & NO PEER
if QAOSCREV=""
QUIT
+11 ; EXCEPTION
SET QAOSFIND=+$PIECE(QAOSCREV,"^",5)
if QAOSFIND=QAOSFIND(3)
QUIT
+12 ;
+13 ; MGMT actions
+14 KILL SERV
SET QAOSS1=0
+15 FOR
SET QAOSS1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSS1))
if QAOSS1'>0
QUIT
Begin DoDot:1
+16 SET QA=$GET(^QA(741,QAOSD0,"REVR",QAOSS1,0))
SET SERV=+$PIECE(QA,"^",10)
+17 if $GET(SERV(SERV))
QUIT
SET SERV(SERV)=1
SET QAOSS2=0
+18 FOR
SET QAOSS2=$ORDER(^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2))
if QAOSS2'>0
QUIT
Begin DoDot:2
+19 SET Y=+^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2,0)
SET X=+$GET(^QA(741.7,Y,0))
+20 SET QAOSACTN(QAOSSTAT,X)=$GET(QAOSACTN(QAOSSTAT,X))+1
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 ; BED SERVICE SPECIFIC occur
+24 SET QAOSHOSP=+$PIECE(QAOSZERO,"^",5)
+25 SET QAOSHOSP(0)=$GET(^SC(QAOSHOSP,0))
+26 IF $PIECE(QAOSHOSP(0),"^",3)="C"
Begin DoDot:1
+27 SET SERV=$PIECE(QAOSHOSP(0),"^",8)
+28 if SERV="N"
SET SERV="NE"
+29 QUIT
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 SET QAOSWARD=+$GET(^SC(QAOSHOSP,42))
+32 SET SERV=$PIECE($GET(^DIC(42,QAOSWARD,0)),"^",3)
+33 QUIT
End DoDot:1
+34 SET Y=+$PIECE("^M1^NE1^S2^P3^I4^NH4^R4^SCI4^D4^B4","^"_SERV,2)
+35 IF Y
Begin DoDot:1
+36 SET X=1+$PIECE($GET(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",Y)
+37 SET $PIECE(QAOSRV(QAOSSTAT,QAOSSEQ),"^",Y)=X
+38 SET X=1+$PIECE($GET(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",5)
+39 SET $PIECE(QAOSRV(QAOSSTAT,QAOSSEQ),"^",5)=X
+40 QUIT
End DoDot:1
+41 SET QAOSTEMP=^UTILITY($JOB,"QAOSPSM",QAOSSTAT,QAOSSEQ)
+42 ; # OCCUR REVIEWED CLINICALLY
+43 IF QAOSCREV'="."
SET $PIECE(QAOSTEMP,"^",2)=$PIECE(QAOSTEMP,"^",2)+1
+44 ; # OCCUR REFERRED PEER (CLIN & NO PEER FOUND)
+45 IF $ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSRFPR,0))
Begin DoDot:1
+46 IF $ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0))'>0
Begin DoDot:2
+47 ; # REFERRED PEER
SET $PIECE(QAOSTEMP,"^",3)=$PIECE(QAOSTEMP,"^",3)+1
+48 ; PEER: PENDING
SET $PIECE(QAOSTEMP,"^",7)=$PIECE(QAOSTEMP,"^",7)+1
+49 DO PEND(1)
+50 QUIT
End DoDot:2
+51 QUIT
End DoDot:1
+52 ; OUTCOME PEER: LEVELS 1,2,3
+53 KILL SERV
SET QAOSS1=0
+54 FOR
SET QAOSS1=$ORDER(^QA(741,QAOSD0,"REVR","AONLY1",1,QAOSS1))
if QAOSS1'>0
QUIT
Begin DoDot:1
+55 SET QA=$GET(^QA(741,QAOSD0,"REVR",QAOSS1,0))
+56 ; NOT PEER ! NOT FINAL
if ($PIECE(QA,"^")'=QAOSPEER)!($PIECE(QA,"^",9)'>0)
QUIT
+57 SET QAOSLEVL=$PIECE(QA,"^",5)
SET SERV=+$PIECE(QA,"^",10)
SET SERV(SERV)=1
+58 ; # REFERRED PEER
SET $PIECE(QAOSTEMP,"^",3)=$PIECE(QAOSTEMP,"^",3)+1
+59 IF QAOSLEVL=QAOSFIND(11)
SET $PIECE(QAOSTEMP,"^",4)=$PIECE(QAOSTEMP,"^",4)+1
+60 IF QAOSLEVL=QAOSFIND(12)
SET $PIECE(QAOSTEMP,"^",5)=$PIECE(QAOSTEMP,"^",5)+1
+61 IF QAOSLEVL=QAOSFIND(13)
SET $PIECE(QAOSTEMP,"^",6)=$PIECE(QAOSTEMP,"^",6)+1
+62 QUIT
End DoDot:1
+63 ; OUTCOME PEER: PENDING
+64 SET QAOSS1=0
+65 FOR
SET QAOSS1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSS1))
if QAOSS1'>0
QUIT
Begin DoDot:1
+66 SET SERV=+$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSS1,0)),"^",10)
+67 if $GET(SERV(SERV))
QUIT
SET SERV(SERV)=1
+68 ; # REFERRED PEER
SET $PIECE(QAOSTEMP,"^",3)=$PIECE(QAOSTEMP,"^",3)+1
+69 ; PEER: PENDING
SET $PIECE(QAOSTEMP,"^",7)=$PIECE(QAOSTEMP,"^",7)+1
+70 DO PEND(2)
+71 QUIT
End DoDot:1
+72 ; # OCCUR REFERRED SYS PROB
+73 FOR X=5,7,8,9
IF QAOSFIND=QAOSFIND(X)
Begin DoDot:1
+74 SET $PIECE(QAOSTEMP,"^",8)=$PIECE(QAOSTEMP,"^",8)+1
+75 QUIT
End DoDot:1
QUIT
+76 ; # OCCUR REFERRED EQUIP PROB
+77 FOR X=4,6,8,9
IF QAOSFIND=QAOSFIND(X)
Begin DoDot:1
+78 SET $PIECE(QAOSTEMP,"^",9)=$PIECE(QAOSTEMP,"^",9)+1
+79 QUIT
End DoDot:1
QUIT
+80 SET ^UTILITY($JOB,"QAOSPSM",QAOSSTAT,QAOSSEQ)=QAOSTEMP
+81 QUIT
PEND(Y) ; SAVE PENDING , PENDING TYPE (Y=1/2)
+1 SET QAOSDPT=$GET(^DPT(+QAOSZERO,0))
SET QAOSSN=$PIECE(QAOSDPT,"^",9)
+2 SET QAOSPAT=$SELECT($PIECE(QAOSDPT,"^")]"":$PIECE(QAOSDPT,"^"),1:+QAOSZERO)
+3 SET QAOSDATE=+$PIECE(QAOSZERO,"^",3)
SET X=QAOSSN_"^"_Y
+4 SET ^UTILITY($JOB,"QAOSPEND",QAOSSCRN,QAOSDATE,QAOSPAT,QAOSD0)=X
+5 QUIT
