- 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 Feb 18, 2025@23:53:57 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