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
PSULR0 ;BIR/PDW - PBM LABORATORY EXTRACT ;25 AUG 1998
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
EN ;EP Tasking Entry Point for generating LAB mail messages, Summaries, & Prints
+1 ;
+2 ; pull in fresh copy of variables
+3 SET PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,ZTIO,PSUSNDR,PSUOPTS"
+4 FOR I=1:1:$LENGTH(PSUVARS,",")
SET @$PIECE(PSUVARS,",",I)=$PIECE(^XTMP("PSU_"_PSUJOB,1),U,I)
+5 ; save off a copy of variables
+6 ;S X="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUSNDR,PSULRSUB,PSULRJOB,PSUJOB,PSUOPTN,PSURTN"
+7 ;F I=1:1 S Y=$P(X,",",I) Q:Y="" I $D(@Y) S X(Y)=@Y
+8 ;M ^XTMP(PSULRSUB,"SAVE")=X
+9 KILL X
+10 ;
+11 ; process Lab entries put into ^XTMP(PSULRSUB,"EVENTS") by IV, UD, OP
+12 ;
+13 DO EN^PSULR1
+14 ; Gather patient test(s) 'CH' nodes and get test results
DO EN^PSULR2
+15 ; Generate Records for detailed message and source for summary
DO EN^PSULR3
+16 KILL PSUMSG
+17 ; Generate Detailed Mail Message
DO EN^PSULR4(.PSUMSG)
+18 SET PSUSUB="PSU_"_PSUJOB
+19 IF $DATA(^XTMP(PSUSUB))
IF PSUMASF
MERGE ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
+20 IF $DATA(^XTMP(PSUSUB))
IF PSUPBMG
MERGE ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
+21 ; Summaries
DO EN^PSULR5
+22 QUIT
+23 ;
PRINT ;EP Tasking Entry Point for generating LAB printouts
+1 DO EN^PSULR6
+2 QUIT
+3 ;
EXIT ;EP EXIT
+1 MERGE Z=^XTMP(PSUARSUB,PSUARJOB,"SAVE")
+2 KILL ^XTMP(PSUARJOB)
+3 ; Kill PSU Variables
+4 DO VARKILL^PSUTL
+5 ; Restore Important Variables
+6 SET Y=""
FOR
SET Y=$ORDER(Z(Y))
IF Y=""
QUIT
SET @Y=Z(Y)
+7 KILL Z
+8 QUIT
+9 ;
LAB(PSUPK,PSUDIV,PSUORD,PSUDFN,PSUDRGNM,PSUDRCD) ;EP pass by value into lab extract
+1 ; No Drug Class Code passed
IF PSUDRCD=""
QUIT
+2 ; PSUPK - Package "IV" "UD" "OP"
+3 ; PSUDIV - DIVISION ( internal form )
+4 ; PSUORD - ORDER NUMBER (IV - order # , UD - order # , OP - Prescription Number)
+5 ; PSUDFN - Patient IEN
+6 ; PSUDRGN - Drug Generic Name ["FREE TEXT"]
+7 ; PSUDRCD - VA Drug Class Code
+8 ;
+9 ; Screen out test patients
+10 IF $$TESTPAT^PSUTL1(PSUDFN)
QUIT
+11 ;
+12 NEW PSULRDA
+13 ; set basics
+14 IF '$GET(PSUJOB)
SET PSUJOB=$JOB
+15 IF '$GET(PSULRSUB)
SET PSULRSUB="PSULR_"_PSUJOB
+16 IF '$GET(PSULRJOB)
SET PSULRJOB=PSUJOB
+17 IF '$DATA(^XTMP(PSULRSUB,PSULRJOB))
Begin DoDot:1
+18 SET X1=DT
SET X2=+0
DO C^%DTC
+19 SET ^XTMP(PSULRSUB,PSULRJOB)=DT_U_X_U_" PBM LAB EXTRACT"
End DoDot:1
+20 ;
+21 ; Setup XTMP for Lab
+22 SET X1=DT
SET X2=6
DO C^%DTC
+23 SET ^XTMP(PSULRSUB,0)=X_U_DT_"^ PBM Extract - Laboratory Module"
+24 ;
+25 IF '$DATA(^XTMP(PSULRSUB,"CODES"))
DO SETCODES
+26 ;
+27 ; test to see if one of the select drug class codes
+28 IF '$DATA(^XTMP(PSULRSUB,"CODES",PSUDRCD))
QUIT
+29 ;
+30 ; store event
+31 SET PSULRDA=$ORDER(^XTMP(PSULRSUB,"EVENT",""),-1)+1
+32 SET ^XTMP(PSULRSUB,"EVENT",PSULRDA)=PSUPK_U_PSUDIV_U_PSUDFN_U_PSUORD_U_PSUDRGNM_U_PSUDRCD
+33 QUIT
+34 ;
SETCODES ;EP TO SETUP CODES
+1 ; set basics
+2 IF '$GET(PSUJOB)
SET PSUJOB=$JOB
+3 IF '$GET(PSULRSUB)
SET PSULRSUB="PSULR_"_PSUJOB
+4 IF '$GET(PSULRJOB)
SET PSULRJOB=PSUJOB
+5 IF '$DATA(^XTMP(PSULRSUB,PSULRJOB))
Begin DoDot:1
+6 SET X1=DT
SET X2=+0
DO C^%DTC
+7 SET ^XTMP(PSULRSUB,PSULRJOB)=DT_U_X_U_" PBM LAB EXTRACT"
End DoDot:1
+8 FOR X="AN500","CV200","CV350","CV800","GA301","HS502"
SET ^XTMP(PSULRSUB,"CODES",X)=""
+9 QUIT
+10 ;
CLEAR ;EP Clear PSULR out of XTMP
+1 SET X="PSULR"
+2 FOR
SET X=$ORDER(^XTMP(X))
IF $EXTRACT(X,1,5)'="PSULR"
QUIT
WRITE !,X
KILL ^XTMP(X)
+3 QUIT
