- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSULR0 3076 printed Feb 18, 2025@23:53:56 Page 2
- 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