92 lines
2.9 KiB
Mathematica
92 lines
2.9 KiB
Mathematica
PSULR0 ;BIR/PDW - PBM LABORATORY EXTRACT ;25 AUG 1998
|
|
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
|
|
;
|
|
EN ;EP Tasking Entry Point for generating LAB mail messages, Summaries, & Prints
|
|
;
|
|
; pull in fresh copy of variables
|
|
S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,ZTIO,PSUSNDR,PSUOPTS"
|
|
F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P(^XTMP("PSU_"_PSUJOB,1),U,I)
|
|
; save off a copy of variables
|
|
;S X="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUSNDR,PSULRSUB,PSULRJOB,PSUJOB,PSUOPTN,PSURTN"
|
|
;F I=1:1 S Y=$P(X,",",I) Q:Y="" I $D(@Y) S X(Y)=@Y
|
|
;M ^XTMP(PSULRSUB,"SAVE")=X
|
|
K X
|
|
;
|
|
; process Lab entries put into ^XTMP(PSULRSUB,"EVENTS") by IV, UD, OP
|
|
;
|
|
D EN^PSULR1
|
|
D EN^PSULR2 ; Gather patient test(s) 'CH' nodes and get test results
|
|
D EN^PSULR3 ; Generate Records for detailed message and source for summary
|
|
K PSUMSG
|
|
D EN^PSULR4(.PSUMSG) ; Generate Detailed Mail Message
|
|
S PSUSUB="PSU_"_PSUJOB
|
|
I $D(^XTMP(PSUSUB)),PSUMASF M ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
|
|
I $D(^XTMP(PSUSUB)),PSUPBMG M ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
|
|
D EN^PSULR5 ; Summaries
|
|
Q
|
|
;
|
|
PRINT ;EP Tasking Entry Point for generating LAB printouts
|
|
D EN^PSULR6
|
|
Q
|
|
;
|
|
EXIT ;EP EXIT
|
|
M Z=^XTMP(PSUARSUB,PSUARJOB,"SAVE")
|
|
K ^XTMP(PSUARJOB)
|
|
; Kill PSU Variables
|
|
D VARKILL^PSUTL
|
|
; Restore Important Variables
|
|
S Y="" F S Y=$O(Z(Y)) Q:Y="" S @Y=Z(Y)
|
|
K Z
|
|
Q
|
|
;
|
|
LAB(PSUPK,PSUDIV,PSUORD,PSUDFN,PSUDRGNM,PSUDRCD) ;EP pass by value into lab extract
|
|
I PSUDRCD="" Q ; No Drug Class Code passed
|
|
; PSUPK - Package "IV" "UD" "OP"
|
|
; PSUDIV - DIVISION ( internal form )
|
|
; PSUORD - ORDER NUMBER (IV - order # , UD - order # , OP - Prescription Number)
|
|
; PSUDFN - Patient IEN
|
|
; PSUDRGN - Drug Generic Name ["FREE TEXT"]
|
|
; PSUDRCD - VA Drug Class Code
|
|
;
|
|
; Screen out test patients
|
|
Q:$$TESTPAT^PSUTL1(PSUDFN)
|
|
;
|
|
N PSULRDA
|
|
; set basics
|
|
I '$G(PSUJOB) S PSUJOB=$J
|
|
I '$G(PSULRSUB) S PSULRSUB="PSULR_"_PSUJOB
|
|
I '$G(PSULRJOB) S PSULRJOB=PSUJOB
|
|
I '$D(^XTMP(PSULRSUB,PSULRJOB)) D
|
|
. S X1=DT,X2=+0 D C^%DTC
|
|
. S ^XTMP(PSULRSUB,PSULRJOB)=DT_U_X_U_" PBM LAB EXTRACT"
|
|
;
|
|
; Setup XTMP for Lab
|
|
S X1=DT,X2=6 D C^%DTC
|
|
S ^XTMP(PSULRSUB,0)=X_U_DT_"^ PBM Extract - Laboratory Module"
|
|
;
|
|
I '$D(^XTMP(PSULRSUB,"CODES")) D SETCODES
|
|
;
|
|
; test to see if one of the select drug class codes
|
|
I '$D(^XTMP(PSULRSUB,"CODES",PSUDRCD)) Q
|
|
;
|
|
; store event
|
|
S PSULRDA=$O(^XTMP(PSULRSUB,"EVENT",""),-1)+1
|
|
S ^XTMP(PSULRSUB,"EVENT",PSULRDA)=PSUPK_U_PSUDIV_U_PSUDFN_U_PSUORD_U_PSUDRGNM_U_PSUDRCD
|
|
Q
|
|
;
|
|
SETCODES ;EP TO SETUP CODES
|
|
; set basics
|
|
I '$G(PSUJOB) S PSUJOB=$J
|
|
I '$G(PSULRSUB) S PSULRSUB="PSULR_"_PSUJOB
|
|
I '$G(PSULRJOB) S PSULRJOB=PSUJOB
|
|
I '$D(^XTMP(PSULRSUB,PSULRJOB)) D
|
|
. S X1=DT,X2=+0 D C^%DTC
|
|
. S ^XTMP(PSULRSUB,PSULRJOB)=DT_U_X_U_" PBM LAB EXTRACT"
|
|
F X="AN500","CV200","CV350","CV800","GA301","HS502" S ^XTMP(PSULRSUB,"CODES",X)=""
|
|
Q
|
|
;
|
|
CLEAR ;EP Clear PSULR out of XTMP
|
|
S X="PSULR"
|
|
F S X=$O(^XTMP(X)) Q:$E(X,1,5)'="PSULR" W !,X K ^XTMP(X)
|
|
Q
|