source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSPSM0.m@ 1093

Last change on this file since 1093 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1QAOSPSM0 ;HISC/DAD-SUMMARY OF OCCURRENCE SCREENING - GET DATA ;12/8/93 11:51
2 ;;3.0;Occurrence Screen;**2,5**;09/14/1993
3 K ^UTILITY($J,"QAOSPSM"),^UTILITY($J,"QAOSXREF"),^UTILITY($J,"QAOSPEND")
4 K QAOSACTN,QAOSRV S QAOSLIST=""
5 F QA=1:1:$L(QAOSLIST(0),",") D
6 . S QAO=$P(QAOSLIST(0),",",QA)
7 . S QAOSLIST=QAOSLIST_$S(QAO="1":"^N",QAO=2:"^L",QAO=3:"^1",1:"^")
8 . Q
9 S (QAOSNUM("N"),QAOSNUM("L"),QAOSNUM("1"))=1
10 F QAOSCRN=0:0 S QAOSCRN=$O(^QA(741.1,"B",QAOSCRN)) Q:QAOSCRN'>0 D
11 . F QAOSD0=0:0 S QAOSD0=$O(^QA(741.1,"B",QAOSCRN,QAOSD0)) Q:QAOSD0'>0 D
12 .. S QAOS=$G(^QA(741.1,QAOSD0,0)),QA=$P(QAOS,"^",4)
13 .. Q:QAOSLIST'[("^"_QA_"^")
14 .. S ^UTILITY($J,"QAOSPSM",QA,QAOSNUM(QA))=+QAOS
15 .. S ^UTILITY($J,"QAOSXREF",+QAOS)=QAOSNUM(QA)_"^"_QA
16 .. S QAOSNUM(QA)=QAOSNUM(QA)+1
17 .. Q
18 . Q
19 S QAOSCLIN=+$O(^QA(741.2,"C",1,0)),QAOSPEER=+$O(^QA(741.2,"C",2,0))
20 S QAOSMGMT=+$O(^QA(741.2,"C",3,0)),QAOSRFPR=+$O(^QA(741.7,"B",2,0))
21 F QA=1:1:16 S QAOSFIND(QA)=+$O(^QA(741.6,"B",QA,0))
22 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
23 Q
24LOOP1 ;
25 S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:(QAOSZERO="")!($P(QAOSZERO,"^",11)=2)
26 S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN"))
27 S QAOSSCRN(0)=$G(^QA(741.1,QAOSSCRN,0))
28 S QAO=$G(^UTILITY($J,"QAOSXREF",+QAOSSCRN(0))),QAOSSEQ=+QAO
29 S QAOSSTAT=$P(QAO,"^",2) Q:QAOSLIST'[("^"_QAOSSTAT_"^")
30 S QAOSD1=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
31 S QAOSCREV=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
32 ; If Exist(Peer) &' Exist(Clin) set QAOSCREV="."
33 I QAOSCREV="",$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0)) S QAOSCREV="."
34 Q:QAOSCREV="" ; NO CLIN & NO PEER
35 S QAOSFIND=+$P(QAOSCREV,"^",5) Q:QAOSFIND=QAOSFIND(3) ; EXCEPTION
36 ;
37 ; MGMT actions
38 K SERV S QAOSS1=0
39 F S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSS1)) Q:QAOSS1'>0 D
40 . S QA=$G(^QA(741,QAOSD0,"REVR",QAOSS1,0)),SERV=+$P(QA,"^",10)
41 . Q:$G(SERV(SERV)) S SERV(SERV)=1,QAOSS2=0
42 . F S QAOSS2=$O(^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2)) Q:QAOSS2'>0 D
43 .. S Y=+^QA(741,QAOSD0,"REVR",QAOSS1,2,QAOSS2,0),X=+$G(^QA(741.7,Y,0))
44 .. S QAOSACTN(QAOSSTAT,X)=$G(QAOSACTN(QAOSSTAT,X))+1
45 .. Q
46 . Q
47 ; BED SERVICE SPECIFIC occur
48 S QAOSHOSP=+$P(QAOSZERO,"^",5)
49 S QAOSHOSP(0)=$G(^SC(QAOSHOSP,0))
50 I $P(QAOSHOSP(0),"^",3)="C" D
51 . S SERV=$P(QAOSHOSP(0),"^",8)
52 . S:SERV="N" SERV="NE"
53 . Q
54 E D
55 . S QAOSWARD=+$G(^SC(QAOSHOSP,42))
56 . S SERV=$P($G(^DIC(42,QAOSWARD,0)),"^",3)
57 . Q
58 S Y=+$P("^M1^NE1^S2^P3^I4^NH4^R4^SCI4^D4^B4","^"_SERV,2)
59 I Y D
60 . S X=1+$P($G(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",Y)
61 . S $P(QAOSRV(QAOSSTAT,QAOSSEQ),"^",Y)=X
62 . S X=1+$P($G(QAOSRV(QAOSSTAT,QAOSSEQ)),"^",5)
63 . S $P(QAOSRV(QAOSSTAT,QAOSSEQ),"^",5)=X
64 . Q
65 S QAOSTEMP=^UTILITY($J,"QAOSPSM",QAOSSTAT,QAOSSEQ)
66 ; # OCCUR REVIEWED CLINICALLY
67 I QAOSCREV'="." S $P(QAOSTEMP,"^",2)=$P(QAOSTEMP,"^",2)+1
68 ; # OCCUR REFERRED PEER (CLIN & NO PEER FOUND)
69 I $O(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QAOSRFPR,0)) D
70 . I $O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,0))'>0 D
71 .. S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
72 .. S $P(QAOSTEMP,"^",7)=$P(QAOSTEMP,"^",7)+1 ; PEER: PENDING
73 .. D PEND(1)
74 .. Q
75 . Q
76 ; OUTCOME PEER: LEVELS 1,2,3
77 K SERV S QAOSS1=0
78 F S QAOSS1=$O(^QA(741,QAOSD0,"REVR","AONLY1",1,QAOSS1)) Q:QAOSS1'>0 D
79 . S QA=$G(^QA(741,QAOSD0,"REVR",QAOSS1,0))
80 . Q:($P(QA,"^")'=QAOSPEER)!($P(QA,"^",9)'>0) ; NOT PEER ! NOT FINAL
81 . S QAOSLEVL=$P(QA,"^",5),SERV=+$P(QA,"^",10),SERV(SERV)=1
82 . S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
83 . I QAOSLEVL=QAOSFIND(11) S $P(QAOSTEMP,"^",4)=$P(QAOSTEMP,"^",4)+1
84 . I QAOSLEVL=QAOSFIND(12) S $P(QAOSTEMP,"^",5)=$P(QAOSTEMP,"^",5)+1
85 . I QAOSLEVL=QAOSFIND(13) S $P(QAOSTEMP,"^",6)=$P(QAOSTEMP,"^",6)+1
86 . Q
87 ; OUTCOME PEER: PENDING
88 S QAOSS1=0
89 F S QAOSS1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSS1)) Q:QAOSS1'>0 D
90 . S SERV=+$P($G(^QA(741,QAOSD0,"REVR",QAOSS1,0)),"^",10)
91 . Q:$G(SERV(SERV)) S SERV(SERV)=1
92 . S $P(QAOSTEMP,"^",3)=$P(QAOSTEMP,"^",3)+1 ; # REFERRED PEER
93 . S $P(QAOSTEMP,"^",7)=$P(QAOSTEMP,"^",7)+1 ; PEER: PENDING
94 . D PEND(2)
95 . Q
96 ; # OCCUR REFERRED SYS PROB
97 F X=5,7,8,9 I QAOSFIND=QAOSFIND(X) D Q
98 . S $P(QAOSTEMP,"^",8)=$P(QAOSTEMP,"^",8)+1
99 . Q
100 ; # OCCUR REFERRED EQUIP PROB
101 F X=4,6,8,9 I QAOSFIND=QAOSFIND(X) D Q
102 . S $P(QAOSTEMP,"^",9)=$P(QAOSTEMP,"^",9)+1
103 . Q
104 S ^UTILITY($J,"QAOSPSM",QAOSSTAT,QAOSSEQ)=QAOSTEMP
105 Q
106PEND(Y) ; SAVE PENDING , PENDING TYPE (Y=1/2)
107 S QAOSDPT=$G(^DPT(+QAOSZERO,0)),QAOSSN=$P(QAOSDPT,"^",9)
108 S QAOSPAT=$S($P(QAOSDPT,"^")]"":$P(QAOSDPT,"^"),1:+QAOSZERO)
109 S QAOSDATE=+$P(QAOSZERO,"^",3),X=QAOSSN_"^"_Y
110 S ^UTILITY($J,"QAOSPEND",QAOSSCRN,QAOSDATE,QAOSPAT,QAOSD0)=X
111 Q
Note: See TracBrowser for help on using the repository browser.