source: FOIAVistA/tag/r/NOIS-FSC/FSCRPCGS.m@ 1383

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1FSCRPCGS ;SLC/STAFF-NOIS RPC Site Profile ;1/13/98 15:47
2 ;;1.1;NOIS;;Sep 06, 1998
3 ;
4SITE(SITE) ; from FSCRPCG
5 N AZERO,CNT,ELEVEN,FOUR,LINE,NAME,NUM,ONE,ONETHREE,SITENUM,SZERO,TWOONE,TWOFOUR,VALUE,VVER,ZERO
6 S SITENUM=+$$STSITE^FSCRPCOC(SITE)
7 S CNT=0
8 S ZERO=$G(^NTS(2050,SITENUM,0)),ONE=$G(^(1)),FOUR=$G(^(4)),ELEVEN=$G(^(11)),ONETHREE=$G(^(13)),TWOONE=$G(^(21)),TWOFOUR=$G(^(24))
9 I '$L(ZERO) Q
10 D SET("------------------------------------------------------------------------------",.CNT)
11 S LINE=" SITE PROFILE REPORT "_$P(ZERO,U)
12 S VALUE=$$FMTE^XLFDT($$NOW^XLFDT)
13 S LINE=$$SETSTR^VALM1(VALUE,LINE,55,$L(VALUE))
14 D SET(LINE,.CNT)
15 D SET("------------------------------------------------------------------------------",.CNT)
16 D SET("FACILITY INFORMATION:",.CNT)
17 D SET("=====================",.CNT)
18 S LINE="NAME: "_$P(ZERO,U)
19 S LINE=$$SETSTR^VALM1("FACILITY NUMBER: ",LINE,45,20)_SITENUM
20 D SET(LINE,.CNT)
21 S LINE="ADDRESS1: "_$P(ONE,U)
22 S LINE=$$SETSTR^VALM1("SUPPORTING ISC: ",LINE,45,20)_$$VALUE^FSCGET($P(ZERO,U,3),2050,2)
23 D SET(LINE,.CNT)
24 S LINE="ADDRESS2: "_$P(ONE,U,2)
25 S LINE=$$SETSTR^VALM1("NEW REGION: ",LINE,45,20)_$P(ZERO,U,8)
26 D SET(LINE,.CNT)
27 S LINE="CITY: "_$P(ONE,U,3)
28 D SET(LINE,.CNT)
29 S LINE="STATE: "_$$VALUE^FSCGET($P(ONE,U,4),2050,7)
30 S LINE=$$SETSTR^VALM1("FTS TELEPHONE NO: ",LINE,45,20)_$P(ONE,U,6)
31 D SET(LINE,.CNT)
32 S LINE="ZIP CODE: "_$P(ONE,U,5)
33 S LINE=$$SETSTR^VALM1("COMM. TELEPHONE NO: ",LINE,45,20)_$P(ONE,U,7)
34 D SET(LINE,.CNT)
35 D SET("",.CNT)
36 S LINE="FAX LOCATIONS: FAX FTS FAX COMMERCIAL"
37 D SET(LINE,.CNT)
38 S LINE=" ------- --------------"
39 D SET(LINE,.CNT)
40 S NUM=0 F S NUM=$O(^NTS(2050,SITENUM,19,NUM)) Q:NUM<1 S VALUE=$G(^(NUM,0)) I $L(VALUE) D
41 .S LINE=" "_$P(VALUE,U)
42 .S LINE=$$SETSTR^VALM1($P(VALUE,U,2),LINE,30,15)_$P(VALUE,U,3)
43 .D SET(LINE,.CNT)
44 D SET("",.CNT)
45 D SET("VAMC STAFF:",.CNT)
46 D SET("===========",.CNT)
47 S LINE="DIRECTOR: "_$P(FOUR,U)
48 S LINE=$$SETSTR^VALM1($P(FOUR,U,2),LINE,55,20)
49 D SET(LINE,.CNT)
50 S LINE="ASSOCIATE DIRECTOR: "_$P(FOUR,U,3)
51 S LINE=$$SETSTR^VALM1($P(FOUR,U,4),LINE,55,20)
52 D SET(LINE,.CNT)
53 S LINE="ASSISTANT DIRECTOR: "_$P(FOUR,U,9)
54 S LINE=$$SETSTR^VALM1($P(FOUR,U,10),LINE,55,20)
55 D SET(LINE,.CNT)
56 S LINE="CHIEF OF STAFF: "_$P(FOUR,U,5)
57 S LINE=$$SETSTR^VALM1($P(FOUR,U,6),LINE,55,20)
58 D SET(LINE,.CNT)
59 S LINE="IRM SERVICE CHIEF: "_$P(TWOONE,U)
60 S LINE=$$SETSTR^VALM1($P(TWOONE,U,2),LINE,55,20)
61 D SET(LINE,.CNT)
62 S LINE="ASST IRM CHIEF: "_$P(TWOFOUR,U)
63 S LINE=$$SETSTR^VALM1($P(TWOFOUR,U,2),LINE,55,20)
64 D SET(LINE,.CNT)
65 S LINE="SITE MANAGER: "_$P(FOUR,U,7)
66 S LINE=$$SETSTR^VALM1($P(FOUR,U,8),LINE,55,20)
67 D SET(LINE,.CNT)
68 S LINE="ADP SECURITY OFFICER: "_$P(ONETHREE,U,5)
69 S LINE=$$SETSTR^VALM1($P(ONETHREE,U,6),LINE,55,20)
70 D SET(LINE,.CNT)
71 D SET("",.CNT)
72 S LINE="RANK(1994):"_$P(ZERO,U,7)_" COMPLEX LEVEL(1994): "_$P(TWOONE,U,6)_" DHCP SIZING(1994): "_$P(TWOFOUR,U,5)
73 D SET(LINE,.CNT)
74 D SET("",.CNT)
75 S LINE="APPLICATIONS: Date Last Updated: "_$$FMTE^XLFDT($P(ZERO,U,5))
76 D SET(LINE,.CNT)
77 D SET("=============",.CNT)
78 D SET(" CUR V'ED PACK",.CNT)
79 D SET(" APPLICATION COORDINATOR PHONE # VER VER # INST.",.CNT)
80 D SET("------------- ----------- ------- ----- ---- -------",.CNT)
81 D SET("",.CNT)
82 S NAME="" F S NAME=$O(^DIC(120102,"B",NAME)) Q:NAME="" S NUM=+$O(^(NAME,0)) I NUM D
83 .S VVER=$P($G(^DIC(120102,NUM,0)),U,2)
84 .S LINE=$E(NAME,1,13)
85 .S AZERO=$G(^NTS(2050,SITENUM,8,NUM,0))
86 .S LINE=$$SETSTR^VALM1($P(AZERO,U,2),LINE,17,20)
87 .S LINE=$$SETSTR^VALM1($P(AZERO,U,3),LINE,34,15)
88 .S LINE=$$SETSTR^VALM1($P(AZERO,U,7),LINE,48,8)
89 .S LINE=$$SETSTR^VALM1(VVER,LINE,55,8)
90 .I $L($P(AZERO,U,8)) S LINE=$$SETSTR^VALM1($E($P(AZERO,U,8),4,5)_"/"_$E($P(AZERO,U,8),2,3),LINE,63,8)
91 .D SET(LINE,.CNT)
92 D SET(" *Includes testing and partial package implementation",.CNT)
93 D SET(" based on availability of capacity.",.CNT)
94 D SET("",.CNT)
95 D SET("SYSTEMS SOFTWARE: Version",.CNT)
96 D SET("=================",.CNT)
97 S NUM=0 F S NUM=$O(^NTS(2050,SITENUM,20,NUM)) Q:NUM<1 S SZERO=$G(^(NUM,0)) I $L(SZERO) D
98 .S LINE=$$VALUE^FSCGET($P(SZERO,U),2050.013,.01)
99 .S LINE=$$SETSTR^VALM1($P(SZERO,U,2),LINE,35,10)
100 .D SET(LINE,.CNT)
101 D SET("",.CNT)
102 D SET("DHCP APPLICATION STATISTICS:",.CNT)
103 D SET("============================",.CNT)
104 S LINE="TOTAL PATIENTS REGISTERED: "_$G(^NTS(2050,SITENUM,"WLDG"))
105 S LINE=$$SETSTR^VALM1("TOTAL CLINICS: ",LINE,37,15)_$G(^NTS(2050,SITENUM,"WLCL"))
106 D SET(LINE,.CNT)
107 S LINE="TOTAL PRESCRIPTIONS: "_$G(^NTS(2050,SITENUM,"WLPS"))
108 S LINE=$$SETSTR^VALM1("INTERFACED LAB INSTRUMENTS: ",LINE,37,28)_$P(ELEVEN,U)
109 D SET(LINE,.CNT)
110 Q
111 ;
112SET(LINE,CNT) ;
113 S CNT=CNT+1
114 S ^TMP("FSCRPC",$J,"OUTPUT",CNT)=LINE
115 Q
116 ;
117TEST ;
118 N NUM,SITE
119 S SITE=100
120 D SITE(SITE)
121 S NUM=0 F S NUM=$O(^TMP("FSCRPC",$J,"OUTPUT",NUM)) Q:NUM<1 W !,^(NUM)
122 Q
Note: See TracBrowser for help on using the repository browser.