source: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULR0.m@ 628

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