source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSPSS0.m@ 701

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1QAOSPSS0 ;HISC/DAD-OCCURRENCE SERVICE STATISTICS SORT ;2/16/93 11:41
2 ;;3.0;Occurrence Screen;;09/14/1993
3 K ^UTILITY($J,"QAOSPSS"),^UTILITY($J,"QAOSXREF"),^UTILITY($J,"QAOQIP")
4 S QAOSCLIN=+$O(^QA(741.2,"C",1,0)),QAOSEXCP=+$O(^QA(741.6,"B",3,0)),QAOSLIST=""
5 F QA=1:1:$L(QAOSLIST(0),",") S QAO=$P(QAOSLIST(0),",",QA),QAOSLIST=QAOSLIST_$S(QAO="1":"^N",QAO=2:"^L",QAO=3:"^1",1:"^")
6 S QAOS=$P(^DD(42,.03,0),"^",3)_"~:~UNKNOWN;" K QAOSSERV F QA=1:1:$L(QAOS,";")-1 S X=$P(QAOS,";",QA),QAOSSERV($P(X,":",2))=$P(X,":",1)
7 S QAOS="",QA=1 F QAOS(0)=0:0 S QAOS=$O(QAOSSERV(QAOS)) Q:QAOS="" S X=QAOSSERV(QAOS),QAOSSERV(X)=QAOS_"^"_QA,QA=QA+1 K QAOSSERV(QAOS)
8 S (QAOSSEQ("L"),QAOSSEQ("N"),QAOSSEQ("1"))=1 F QAOSCRN=0:0 S QAOSCRN=$O(^QA(741.1,"B",QAOSCRN)) Q:QAOSCRN'>0 F QAOSD0=0:0 S QAOSD0=$O(^QA(741.1,"B",QAOSCRN,QAOSD0)) Q:QAOSD0'>0 D LOOP0
9 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
10 Q
11LOOP0 ;
12 ; ^UTILITY($J,"QAOSXREF",SCREEN#)=SEQUENCE# ^ STATUS
13 S QAOSSCRN=$G(^QA(741.1,QAOSD0,0)),QAOSTYPE=$P(QAOSSCRN,"^",4) Q:QAOSLIST'[("^"_QAOSTYPE_"^")
14 I QAOSSORT="S" S QA="" F QA(0)=0:0 S QA=$O(QAOSSERV(QA)) Q:QA="" S ^UTILITY($J,"QAOSPSS",QAOSTYPE,$P(QAOSSERV(QA),"^"),QAOSSEQ(QAOSTYPE))=+QAOSSCRN_"^0"
15 I QAOSSORT="C" S ^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ(QAOSTYPE))=+QAOSSCRN_"^0^0^0^0^0^0^0^0^0^0^0^0"
16 S ^UTILITY($J,"QAOSXREF",+QAOSSCRN)=QAOSSEQ(QAOSTYPE)_"^"_QAOSTYPE,QAOSSEQ(QAOSTYPE)=QAOSSEQ(QAOSTYPE)+1
17 Q
18LOOP1 ;
19 S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:QAOSZERO=""!($P(QAOSZERO,"^",11)=2)
20 S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN")) Q:QAOSSCRN'>0 S QAOSSCRN(0)=+$G(^QA(741.1,QAOSSCRN,0)) Q:QAOSSCRN(0)'>0
21 S QAOSD1=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0)),QAOSFIND=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5) Q:QAOSFIND=QAOSEXCP
22 S QAOS=$G(^UTILITY($J,"QAOSXREF",QAOSSCRN(0))),QAOSSEQ=+QAOS,QAOSTYPE=$P(QAOS,"^",2) Q:QAOSLIST'[("^"_QAOSTYPE_"^")
23 S QAOSHIEN=+$P(QAOSZERO,"^",5)
24 S QAOSHIEN(0)=$G(^SC(QAOSHIEN,0))
25 I $P(QAOSHIEN(0),"^",3)="C" D
26 . S QAOSSERV(0)=$P(QAOSHIEN(0),"^",8)
27 . S:QAOSSERV(0)="N" QAOSSERV(0)="NE"
28 . S:QAOSSERV(0)="0" QAOSSERV(0)="~"
29 . Q
30 E D
31 . S QAOSWIEN=+$G(^SC(QAOSHIEN,42))
32 . S QAOSSERV(0)=$P($G(^DIC(42,QAOSWIEN,0)),"^",3)
33 . Q
34 S:QAOSSERV(0)="" QAOSSERV(0)="~"
35 S QAOSSERV=$S($D(QAOSSERV(QAOSSERV(0)))#2:$P(QAOSSERV(QAOSSERV(0)),"^"),1:"~UNKNOWN")
36 D SERVICE:QAOSSORT="S",CRITERIA:QAOSSORT="C"
37 Q
38SERVICE ;
39 S QAOSTEMP=^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSERV,QAOSSEQ),$P(QAOSTEMP,"^",2)=$P(QAOSTEMP,"^",2)+1,^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSERV,QAOSSEQ)=QAOSTEMP
40 Q
41CRITERIA ;
42 S QAOPIECE=$P(QAOSSERV(QAOSSERV(0)),"^",2)+1,QAOSTEMP=^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ),$P(QAOSTEMP,"^",QAOPIECE)=$P(QAOSTEMP,"^",QAOPIECE)+1,^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ)=QAOSTEMP
43 S ^UTILITY($J,"QAOQIP",QAOSTYPE,QAOSSEQ,QAOSSERV(0),QAOSD0)=""
44 Q
Note: See TracBrowser for help on using the repository browser.