source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM7.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1PSUDEM7 ;BIR/DAM - Inpatient PTF Record Extract ;20 DEC 2001
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ;DBIA's
5 ; Reference to file 2 supported by DBIA 10035
6 ; Reference to file 4.3 supported by DBIA 2496
7 ; Reference to file 45 supported by DBIA 3511
8 ;
9EN ;EN
10 D DAT
11 D EN^PSUDEM8 ;Gather ICD9 codes
12 I '$D(^XTMP("PSU_"_PSUJOB,"PSUIPV")) D NODATA
13 D XMD
14 K ^XTMP("PSU_"_PSUJOB,"PSUIPV")
15 K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
16 Q
17 ;
18DAT ;Find discharge dates that fall within the extract date range
19 ;as well as discharge dates within the 30 days prior to day 1 of
20 ;of the extract date range.
21 ;
22 S PSUDD=0
23 F S PSUDD=$O(^DGPT("ADS",PSUDD)) Q:'PSUDD D
24 .S PSUDDT=$E(PSUDD,1,7)
25 .S X1=PSUSDT
26 .S X2=(-30)
27 .D C^%DTC
28 .S PSUSDT1=X ;Date 30 days prior to start date
29 .I (PSUDDT>PSUSDT1)!(PSUDDT=PSUSDT1)&(PSUDDT<PSUEDT)!(PSUDDT=PSUEDT) D
30 ..S ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUDDT)=""
31 ..S PSUIEN=0
32 ..F S PSUIEN=$O(^DGPT("ADS",PSUDD,PSUIEN)) Q:'PSUIEN D
33 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,5)=PSUDDT ;Discharge Date
34 ...N PSUDT
35 ...S PSUDT=$P($G(^DGPT(PSUIEN,0)),U,2)
36 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,4)=$E(PSUDT,1,7) ;Admit date
37 ...D INST^PSUDEM1
38 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,2)=PSUSIT ;SITE
39 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,3)=PSUSIT_PSUIEN ;Unique PTF ID
40 ...D SSNICN
41 Q
42 ;
43SSNICN ;Find patient Admission date, SSN and ICN for inpatient record
44 ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
45 ;
46 N PSUPT,PSUICN,PSUICN1
47 S PSUPT=$P($G(^DGPT(PSUIEN,0)),U) ;Pointer to patient file
48 ;
49 N PSUREC
50 I PSUPT D
51 .S PSUREC=$P($G(^DPT(PSUPT,0)),U,9) D REC D
52 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,6)=PSUREC ;Pt SSN
53 .S PSUICN=$$GETICN^MPIF001(PSUPT) D
54 ..I PSUICN'[-1 D
55 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,7)=PSUICN ;ICN
56 Q
57 ;
58REC ;If "^" is contained in any record, replace it with (')
59 ;
60 I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
61 Q
62 ;
63NODATA ;Generate a 'No Data' message if there is no data in the extract
64 ;
65 S NONE=1
66 M PSUXMYH=PSUXMYS1
67 S PSUM=1
68 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,1)="No data to report"
69 Q
70 ;
71XMD ;Format mailman message and send.
72 ;
73 S PSUAB=0,PSUPL=1
74 F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB)) Q:PSUAB="" D
75 .M ^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB) ;Global numerical order
76 .S PSUPL=PSUPL+1
77 ;
78 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
79 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
80 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
81 S PSUMC=1,PSUMLC=0
82 F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSULC)) Q:X="" D
83 .S PSUMLC=PSUMLC+1
84 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message
85 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
86 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
87 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
88 .S PSUMLC=PSUMLC+1
89 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
90 ;
91 ; Count Lines sent
92 S PSUTLC=0
93 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
94 ;
95 F PSUM=1:1:PSUMC D PTF^PSUDEM5
96 D CONF
97 Q
98CONF ;Construct globals for confirmation message
99 ;
100 ;D INST^PSUDEM1
101 I $G(NONE) S PSUTLC=0
102 N PSUDIVIS
103 ;S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
104 S PSUDIVIS=PSUSNDR
105 S PSUSUB="PSU_"_PSUJOB
106 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"M")=PSUMC
107 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"L")=PSUTLC
108 Q
Note: See TracBrowser for help on using the repository browser.