source: FOIAVistA/tag/r/OCCURRENCE_SCREEN-QAO/QAOSPRS0.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1QAOSPRS0 ;HISC/DAD,JCW-REVIEW SUMMARY REPORT ;4/30/93 09:26
2 ;;3.0;Occurrence Screen;;09/14/1993
3 K DIR S DIR(0)="LO^1:3^K:X[""."" X",DIR("A")="Select screen criteria to include",DIR("B")=1
4 S DIR("?",1)="Choose from:",DIR("?",2)=" 1 National",DIR("?",3)=" 2 Local",DIR("?",4)=" 3 Inactive",DIR("?")="Select any combination of the codes listed above, e.g. 1-3, 1,2"
5 W ! D ^DIR G:$D(DIRUT) EXIT S QAOSLIST=$TR(Y,"123,","NL1")
6 W !!,"Select the reporting period:" D ^QAQDATE G:QAQQUIT EXIT
7 W !,"NOTE: This is a 132 column report."
8DEVICE ;
9 K %ZIS S %ZIS="QM",%ZIS("B")="" W ! D ^%ZIS G:POP EXIT
10 I $D(IOM)#2,IOM<132 D ^%ZISC W !?5,"*** Please choose a 132 column output device !! ***",*7 G DEVICE
11 I $D(IO("Q")) K IO("Q") S ZTRTN="ENTSK^QAOSPRS0",(ZTSAVE("QAQ*"),ZTSAVE("QAO*"))="",ZTDESC="Occurrence Screen Review Summary Report" D ^%ZTLOAD G EXIT
12ENTSK ;
13 D SETUP^QAOSPRS2
14 F QAOSDT=QAQNBEG-.0000001:0 S QAOSDT=$O(^QA(741,"C",QAOSDT)) Q:(QAOSDT'>0)!(QAOSDT>(QAQNEND+.24)) F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDT,QAOSD0)) Q:QAOSD0'>0 D LOOP
15 U IO D ^QAOSPRS1
16EXIT ;
17 D ^%ZISC
18 K %DT,%ZIS,DIR,DIRUT,POP,QA,QAOSACTN,QAOSCLIN,QAOSCONF,QAOSD0,QAOSD1,QAOSD2,QAOSDD,QAOSDT,QAOSEVER,QAOSFIND,QAOSHOSP,QAOSIEN,QAOSLIST,QAOSMGMT,QAOSNUM,QAOSPAGE,QAOSPEER,QAOSQOCS,QAOSQUIT,QAOSREVR,QAOSRV,QAOSRVNO
19 K QAOSSCRN,QAOSSERV,QAOSSEVR,QAOSTEXT,QAOSTYPE,QAOSWARD,QAOSZERO,QAOTODAY,QAOTOTAL,TAB,TOT,UNDL1,UNDL2,X,Y,ZTDESC,ZTRTN,ZTSAVE
20 D KILLTMP^QAOSPRS2,K^QAQDATE
21 S:$D(ZTQUEUED) ZTREQ="@"
22 Q
23LOOP ;
24 S QAOSZERO=$G(^QA(741,QAOSD0,0)),QAOSSCRN=+$G(^("SCRN"))
25 S QAOSTYPE=$P($G(^QA(741.1,QAOSSCRN,0)),"^",4) Q:(QAOSTYPE="")!(QAOSLIST'[QAOSTYPE)
26 S QAOTOTAL("RECR",QAOSTYPE)=QAOTOTAL("RECR",QAOSTYPE)+1
27 I $P(QAOSZERO,"^",11)=2 S QAOTOTAL("DELT",QAOSTYPE)=QAOTOTAL("DELT",QAOSTYPE)+1 Q
28 S QAOSHOSP=+$P(QAOSZERO,"^",5)
29 S QAOSHOSP(0)=$G(^SC(QAOSHOSP,0))
30 I $P(QAOSHOSP(0),"^",3)="C" D
31 . S QAOSSERV=$P(QAOSHOSP(0),"^",8)
32 . S:QAOSSERV="N" QAOSSERV="NE"
33 . S:QAOSSERV="0" QAOSSERV=""
34 . Q
35 E D
36 . S QAOSWARD=+$G(^SC(QAOSHOSP,42))
37 . S QAOSSERV=$P($G(^DIC(42,QAOSWARD,0)),"^",3)
38 . Q
39 S:QAOSSERV="" QAOSSERV="^"
40 S QAOSRVNO=$P("4^11^8^6^5^3^9^10^2^1^7^12","^",$L($P(QAOSRV,QAOSSERV),";"))
41CLIN ;
42 S QAOSFIND=""
43 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,QAOSD1)) Q:(QAOSD1'>0)!(QAOSFIND=3) D
44 . S QAOSFIND=+$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
45 . S QAOSFIND=+$G(^QA(741.6,QAOSFIND,0)) Q:(QAOSFIND'>0)!(QAOSFIND=3)
46 . S ^TMP($J,QAOSTYPE,"CLIN",QAOSFIND)=$G(^TMP($J,QAOSTYPE,"CLIN",QAOSFIND))+1
47 . S QAOTOTAL("CLIN",QAOSTYPE)=QAOTOTAL("CLIN",QAOSTYPE)+1
48 . Q
49 I QAOSFIND=3 S QAOTOTAL("EXCP",QAOSTYPE)=QAOTOTAL("EXCP",QAOSTYPE)+1 Q
50 S QAOTOTAL("OCCR",QAOSTYPE)=QAOTOTAL("OCCR",QAOSTYPE)+1
51PEER ;
52 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1)) Q:QAOSD1'>0 D
53 . S QA=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
54 . Q:$P(QA,"^",9)'>0
55 . S QAOSFIND=+$P(QA,"^",5),QAOSFIND=+$G(^QA(741.6,QAOSFIND,0))
56 . Q:QAOSFIND'>0
57 . S $P(^TMP($J,QAOSTYPE,"PEER",QAOSFIND),"^",QAOSRVNO)=$P($G(^TMP($J,QAOSTYPE,"PEER",QAOSFIND)),"^",QAOSRVNO)+1
58 . S QAOTOTAL("PEER",QAOSTYPE)=QAOTOTAL("PEER",QAOSTYPE)+1
59 . Q
60MGMT ;
61 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,QAOSD1)) Q:QAOSD1'>0 F QAOSD2=0:0 S QAOSD2=$O(^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2)) Q:QAOSD2'>0 D
62 . S QAOSACTN=+^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2,0)
63 . S QAOSACTN=+$G(^QA(741.7,QAOSACTN,0)) Q:QAOSACTN'>0
64 . S $P(^TMP($J,QAOSTYPE,"MGMT",QAOSACTN),"^",QAOSRVNO)=$P($G(^TMP($J,QAOSTYPE,"MGMT",QAOSACTN)),"^",QAOSRVNO)+1
65 . S QAOTOTAL("MGMT",QAOSTYPE)=QAOTOTAL("MGMT",QAOSTYPE)+1
66 . Q
67SEVER ;
68 S QAOSEVER=+$P(QAOSZERO,"^",18),QAOSEVER=$G(^QA(741.8,QAOSEVER,0))
69 I QAOSEVER]"" D
70 . S ^TMP($J,QAOSTYPE,"SEVR",+QAOSEVER)=$G(^TMP($J,QAOSTYPE,"SEVR",+QAOSEVER))+1
71 . S QAOTOTAL("SEVR",QAOSTYPE)=QAOTOTAL("SEVR",QAOSTYPE)+1
72 . Q
73CMTE ;
74 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE",QAOSD1)) Q:QAOSD1'>0 D
75 . S QAOSCONF=$P($G(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",5)
76 . Q:QAOSCONF'>0
77 . S ^TMP($J,QAOSTYPE,"CMTE",QAOSCONF)=$G(^TMP($J,QAOSTYPE,"CMTE",QAOSCONF))+1
78 . S QAOTOTAL("CMTE",QAOSTYPE)=QAOTOTAL("CMTE",QAOSTYPE)+1
79 . Q
80 Q
Note: See TracBrowser for help on using the repository browser.