PSULR1 ;BIR/PDW - PBM LAB EXTRACT ;12 AUG 1999
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
; Extract & setup crosswalk for drug codes and "CH" nodes
; Reference to File # 60 supported by DBIA 2523
; Reference to ^LAM supported by DBIA 2522
EN ;EP Tasking Entry Point for generating LAB mail messages, Summaries, & Prints
;
CODES ; Table for Building Class * Work Load codes * Lab Tests crosswalk
D SETCODES^PSULR0
; Builds ^XTMP(PSULRSUB,"CODES",VA DRUG CLASS,LAB NODE LOCATION)=LAB TEST
; Builds PSUFLAG("BLOOD":"SERUM":"PLASMA") array
S:'$D(PSUJOB) PSUJOB=$J
S:'$D(PSULRJOB) PSULRJOB=PSUJOB
S:'$D(PSULRSUB) PSULRSUB="PSULR_"_PSULRJOB
; Initialize Flag type array
F X="BLOOD","SERUM","PLASMA" S PSUFLAG(X)=""
;
; Loop Drug Class Codes & WorkCodes 3.2.8.7
S X="AN500" F Y=83405,81062 S PSULRX(X,Y)="" D GET
S X="CV200" F Y=82565 S PSULRX(X,Y)="" D GET
S X="CV350" F Y=83017,83013,84480,82466,84455,84465 S PSULRX(X,Y)="" D GET
S X="CV800" F Y=82565,84140 S PSULRX(X,Y)="" D GET
S X="GA301" F Y=82565 S PSULRX(X,Y)="" D GET
S X="HS502" F Y=84330,85053,84455,84465,85052 S PSULRX(X,Y)="" D GET
;
Q
; Follow wrk code into tests 3.2.8.9
GET ;EP Get the appropriate Work Load entry
;
S PSUY=Y_".0000 " D WALK
F S PSUY=$O(^LAM("C",PSUY)) Q:(+PSUY\1'=+Y) D WALK
Q
WALK ;EP Do the crosswalk to get the tests associated with workload
S Z=$O(^LAM("C",PSUY,0))
; 3.2.8.9
I '$D(^LAM(Z,7,"B")) Q
; 3.2.8.10
;
S PSUWKDA=Z
; Loop Multiple & Work on over to file 60 & check site/specimen
S Z="" F S Z=$O(^LAM(PSUWKDA,7,"B",Z)) Q:Z="" D
. S PSULRDA=+Z
. K PSUSPECM
. D GETM^PSUTL(60,PSULRDA,"100*^.01;6","PSUSPECM")
. S DA=0,PSUFLAG=0 F S DA=$O(PSUSPECM(DA)) Q:DA'>0 S W=PSUSPECM(DA,.01) I $D(PSUFLAG(W)) S PSUFLAG=1 Q
. Q:'PSUFLAG
. ; store DrugCode, WrkCode, Lab IEN = Location
. S PSULOC=$$VAL^PSUTL(60,PSULRDA,5),PSULOC=$P(PSULOC,";",2)
. ;S ^XTMP(PSULRSUB,"CODES",X,+Y,PSULRDA)=PSULOC ; Trace Construction
. S ^XTMP(PSULRSUB,"CODES",X,PSULOC)=$$VAL^PSUTL(60,PSULRDA,.01)_U_PSUSPECM(DA,6)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSULR1 2112 printed Dec 13, 2024@02:27:54 Page 2
PSULR1 ;BIR/PDW - PBM LAB EXTRACT ;12 AUG 1999
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ; Extract & setup crosswalk for drug codes and "CH" nodes
+3 ; Reference to File # 60 supported by DBIA 2523
+4 ; Reference to ^LAM supported by DBIA 2522
EN ;EP Tasking Entry Point for generating LAB mail messages, Summaries, & Prints
+1 ;
CODES ; Table for Building Class * Work Load codes * Lab Tests crosswalk
+1 DO SETCODES^PSULR0
+2 ; Builds ^XTMP(PSULRSUB,"CODES",VA DRUG CLASS,LAB NODE LOCATION)=LAB TEST
+3 ; Builds PSUFLAG("BLOOD":"SERUM":"PLASMA") array
+4 if '$DATA(PSUJOB)
SET PSUJOB=$JOB
+5 if '$DATA(PSULRJOB)
SET PSULRJOB=PSUJOB
+6 if '$DATA(PSULRSUB)
SET PSULRSUB="PSULR_"_PSULRJOB
+7 ; Initialize Flag type array
+8 FOR X="BLOOD","SERUM","PLASMA"
SET PSUFLAG(X)=""
+9 ;
+10 ; Loop Drug Class Codes & WorkCodes 3.2.8.7
+11 SET X="AN500"
FOR Y=83405,81062
SET PSULRX(X,Y)=""
DO GET
+12 SET X="CV200"
FOR Y=82565
SET PSULRX(X,Y)=""
DO GET
+13 SET X="CV350"
FOR Y=83017,83013,84480,82466,84455,84465
SET PSULRX(X,Y)=""
DO GET
+14 SET X="CV800"
FOR Y=82565,84140
SET PSULRX(X,Y)=""
DO GET
+15 SET X="GA301"
FOR Y=82565
SET PSULRX(X,Y)=""
DO GET
+16 SET X="HS502"
FOR Y=84330,85053,84455,84465,85052
SET PSULRX(X,Y)=""
DO GET
+17 ;
+18 QUIT
+19 ; Follow wrk code into tests 3.2.8.9
GET ;EP Get the appropriate Work Load entry
+1 ;
+2 SET PSUY=Y_".0000 "
DO WALK
+3 FOR
SET PSUY=$ORDER(^LAM("C",PSUY))
if (+PSUY\1'=+Y)
QUIT
DO WALK
+4 QUIT
WALK ;EP Do the crosswalk to get the tests associated with workload
+1 SET Z=$ORDER(^LAM("C",PSUY,0))
+2 ; 3.2.8.9
+3 IF '$DATA(^LAM(Z,7,"B"))
QUIT
+4 ; 3.2.8.10
+5 ;
+6 SET PSUWKDA=Z
+7 ; Loop Multiple & Work on over to file 60 & check site/specimen
+8 SET Z=""
FOR
SET Z=$ORDER(^LAM(PSUWKDA,7,"B",Z))
if Z=""
QUIT
Begin DoDot:1
+9 SET PSULRDA=+Z
+10 KILL PSUSPECM
+11 DO GETM^PSUTL(60,PSULRDA,"100*^.01;6","PSUSPECM")
+12 SET DA=0
SET PSUFLAG=0
FOR
SET DA=$ORDER(PSUSPECM(DA))
if DA'>0
QUIT
SET W=PSUSPECM(DA,.01)
IF $DATA(PSUFLAG(W))
SET PSUFLAG=1
QUIT
+13 if 'PSUFLAG
QUIT
+14 ; store DrugCode, WrkCode, Lab IEN = Location
+15 SET PSULOC=$$VAL^PSUTL(60,PSULRDA,5)
SET PSULOC=$PIECE(PSULOC,";",2)
+16 ;S ^XTMP(PSULRSUB,"CODES",X,+Y,PSULRDA)=PSULOC ; Trace Construction
+17 SET ^XTMP(PSULRSUB,"CODES",X,PSULOC)=$$VAL^PSUTL(60,PSULRDA,.01)_U_PSUSPECM(DA,6)
End DoDot:1
