source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULR0.m@ 1071

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

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1PSULR0 ;BIR/PDW - PBM LABORATORY EXTRACT ;25 AUG 1998
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4EN ;EP Tasking Entry Point for generating LAB mail messages, Summaries, & Prints
5 ;
6 ; pull in fresh copy of variables
7 S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,ZTIO,PSUSNDR,PSUOPTS"
8 F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P(^XTMP("PSU_"_PSUJOB,1),U,I)
9 ; save off a copy of variables
10 ;S X="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUSNDR,PSULRSUB,PSULRJOB,PSUJOB,PSUOPTN,PSURTN"
11 ;F I=1:1 S Y=$P(X,",",I) Q:Y="" I $D(@Y) S X(Y)=@Y
12 ;M ^XTMP(PSULRSUB,"SAVE")=X
13 K X
14 ;
15 ; process Lab entries put into ^XTMP(PSULRSUB,"EVENTS") by IV, UD, OP
16 ;
17 D EN^PSULR1
18 D EN^PSULR2 ; Gather patient test(s) 'CH' nodes and get test results
19 D EN^PSULR3 ; Generate Records for detailed message and source for summary
20 K PSUMSG
21 D EN^PSULR4(.PSUMSG) ; Generate Detailed Mail Message
22 S PSUSUB="PSU_"_PSUJOB
23 I $D(^XTMP(PSUSUB)),PSUMASF M ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
24 I $D(^XTMP(PSUSUB)),PSUPBMG M ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
25 D EN^PSULR5 ; Summaries
26 Q
27 ;
28PRINT ;EP Tasking Entry Point for generating LAB printouts
29 D EN^PSULR6
30 Q
31 ;
32EXIT ;EP EXIT
33 M Z=^XTMP(PSUARSUB,PSUARJOB,"SAVE")
34 K ^XTMP(PSUARJOB)
35 ; Kill PSU Variables
36 D VARKILL^PSUTL
37 ; Restore Important Variables
38 S Y="" F S Y=$O(Z(Y)) Q:Y="" S @Y=Z(Y)
39 K Z
40 Q
41 ;
42LAB(PSUPK,PSUDIV,PSUORD,PSUDFN,PSUDRGNM,PSUDRCD) ;EP pass by value into lab extract
43 I PSUDRCD="" Q ; No Drug Class Code passed
44 ; PSUPK - Package "IV" "UD" "OP"
45 ; PSUDIV - DIVISION ( internal form )
46 ; PSUORD - ORDER NUMBER (IV - order # , UD - order # , OP - Prescription Number)
47 ; PSUDFN - Patient IEN
48 ; PSUDRGN - Drug Generic Name ["FREE TEXT"]
49 ; PSUDRCD - VA Drug Class Code
50 ;
51 ; Screen out test patients
52 Q:$$TESTPAT^PSUTL1(PSUDFN)
53 ;
54 N PSULRDA
55 ; set basics
56 I '$G(PSUJOB) S PSUJOB=$J
57 I '$G(PSULRSUB) S PSULRSUB="PSULR_"_PSUJOB
58 I '$G(PSULRJOB) S PSULRJOB=PSUJOB
59 I '$D(^XTMP(PSULRSUB,PSULRJOB)) D
60 . S X1=DT,X2=+0 D C^%DTC
61 . S ^XTMP(PSULRSUB,PSULRJOB)=DT_U_X_U_" PBM LAB EXTRACT"
62 ;
63 ; Setup XTMP for Lab
64 S X1=DT,X2=6 D C^%DTC
65 S ^XTMP(PSULRSUB,0)=X_U_DT_"^ PBM Extract - Laboratory Module"
66 ;
67 I '$D(^XTMP(PSULRSUB,"CODES")) D SETCODES
68 ;
69 ; test to see if one of the select drug class codes
70 I '$D(^XTMP(PSULRSUB,"CODES",PSUDRCD)) Q
71 ;
72 ; store event
73 S PSULRDA=$O(^XTMP(PSULRSUB,"EVENT",""),-1)+1
74 S ^XTMP(PSULRSUB,"EVENT",PSULRDA)=PSUPK_U_PSUDIV_U_PSUDFN_U_PSUORD_U_PSUDRGNM_U_PSUDRCD
75 Q
76 ;
77SETCODES ;EP TO SETUP CODES
78 ; set basics
79 I '$G(PSUJOB) S PSUJOB=$J
80 I '$G(PSULRSUB) S PSULRSUB="PSULR_"_PSUJOB
81 I '$G(PSULRJOB) S PSULRJOB=PSUJOB
82 I '$D(^XTMP(PSULRSUB,PSULRJOB)) D
83 . S X1=DT,X2=+0 D C^%DTC
84 . S ^XTMP(PSULRSUB,PSULRJOB)=DT_U_X_U_" PBM LAB EXTRACT"
85 F X="AN500","CV200","CV350","CV800","GA301","HS502" S ^XTMP(PSULRSUB,"CODES",X)=""
86 Q
87 ;
88CLEAR ;EP Clear PSULR out of XTMP
89 S X="PSULR"
90 F S X=$O(^XTMP(X)) Q:$E(X,1,5)'="PSULR" W !,X K ^XTMP(X)
91 Q
Note: See TracBrowser for help on using the repository browser.