PSUPR1 ;BIR/PDW - Data Gathering for PBMS PR file 442 ;12 AUG 1999
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;DBIAs
; Reference to file #442 supported by DBIA 1020
; Reference to file #445.01 supported by DBIA 1021
; Reference to file #420.5 supported by DBIA 1022
; Reference to file #410 supported by DBIA 2345,2409
; Reference to file #440 supported by DBIA 2606
; Reference to file #4.3 supported by DBIA 10091
; Reference to file #50 supported by DBIA 221
;
EN ;EP Entry Point
S PSUEDT=PSUEDT\1+.24
S PSUPRSDT=PSUSDT
S PSUPREDT=PSUEDT
; setup ^XTMP node
S:'$D(PSUPRJOB) PSUPRJOB=$J
S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_PSUPRJOB
I '$D(^XTMP(PSUPRSUB)) D
. S ^XTMP(PSUPRSUB,"RECORDS",0)=""
. S X1=DT,X2=6 D C^%DTC
. S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction"
START ;EP
N PSUDT,PSUDA
S PSURC=0 ; record counter
S PSUDT=PSUPRSDT
F S PSUDT=$O(^PRC(442,"AB",PSUDT)) Q:PSUDT'>0 Q:PSUDT>PSUPREDT D PODATE
Q
;
PODATE ;EP Process a PO DATE
N PSUPODA
; File 442 can not be linked to division so div=sender
; and indicator = "H"
S X=$P($G(^XMB(1,1,"XUS")),U,17)
S PSUDIV=PSUSNDR,PSUDIVI="H"
; Loop POs within date
S PSUPODA=0
F S PSUPODA=$O(^PRC(442,"AB",PSUDT,PSUPODA)) Q:'PSUPODA D PO
Q
;
PO ;EP Process a PO
N PSUPO,PSUCC
S PSUCC=$$VALI^PSUTL(442,PSUPODA,2) ; cost center
I PSUCC'=822400,PSUCC'=828100 Q ; not pharmacy related
S PSUSS=$$VALI^PSUTL(442,PSUPODA,.5) ; supply status
I PSUSS>14,PSUSS<45
E Q ; not within status range
; load po information
D GETS^PSUTL(442,PSUPODA,".01;.1;1;2;5","PSUPO","I")
D MOVEI^PSUTL("PSUPO")
;
; further process po information
S PSUPO(5)=$$VALI^PSUTL(440,PSUPO(5),.01) ; Vendor name
;
; load item information
K ^TMP($J,"PSUMIT")
D GETM^PSUTL(442,PSUPODA,"40*^1;1.5;3;3.1;5;9.3;10;11","^TMP($J,""PSUMIT"")","IN")
D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
;
; loop items
S PSUITDA=0
F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM
Q
;
ITEM ;EP Process one item
N PSUIT,PSUDRDA
M PSUIT=^TMP($J,"PSUMIT",PSUITDA)
;
; Get Drug
S PSUIT(1.5)=+$G(PSUIT(1.5))
S PSUDRDA=$O(^PSDRUG("AB",PSUIT(1.5),0))
N PSUARSUB,PSUARJOB S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB
I PSUDRDA D DRUG^PSUAR2(PSUDRDA) ; setup drug profile
;
; process dispense unit 445 & conversion factor 3.2.6.1.5
S X=+$G(PSUIT(10)),X=+$$VALI^PSUTL(410,X,4)
; disp unit
S PSUIT("DU")=$$VALI^PSUTL(445.01,"X,PSUIT(1.5)",50)
; disp unit conver factor
S PSUIT("DUCV")=$$VALI^PSUTL(445.01,"X,PSUIT(1.5)",51)
; unit of purchase
S PSUIT("UOP")=$$VALI^PSUTL(420.5,+$G(PSUIT(3)),.01)
;
; further process fields
S:'$L($G(PSUIT(9.3))) PSUIT(9.3)="No NDC"
;
;
REC ;EP Assemble record
K PSUR
S PSUG="^XTMP(PSUPRSUB,""PSUDRUG_DET"",PSUDRDA)" ; drug reference
S PSUR(2)=$G(PSUDIV)
S PSUR(3)=$G(PSUDIVI)
S PSUR(4)=$G(PSUPO(.1))
I PSUDRDA D
. S PSUR(5)=@PSUG@(21)
. S PSUR(7)=@PSUG@(.01)
. S PSUR(12)=@PSUG@(14.5)
. S PSUR(6)=@PSUG@(2)
I 'PSUDRDA D
. S PSUR(5)="Unknown VA Product Name"
. S PSUR(7)="Unknown Generic Name"
S PSUR(8)=$G(PSUIT(1,1))_$G(PSUIT(1,2)) S:'$L(PSUR(8)) PSUR(8)="No description listed"
F S X=$E(PSUR(8)) Q:X'=" " S PSUR(8)=$E(PSUR(8),2,999)
S PSUR(8)=$E(PSUR(8),1,50)
S PSUR(9)=$G(PSUIT(9.3))
S PSUR(12)=$G(PSUIT("DU"))
S PSUR(13)=$G(PSUIT("UOP"))
S PSUR(14)=$G(PSUIT(3.1))
S PSUR(15)=PSUIT("DU")
S PSUR(16)=PSUIT("DUCV")
S PSUR(17)=$G(PSUIT(11))
S PSUR(18)=$G(PSUIT(5))
S PSUR(19)=$G(PSUIT(11))*$G(PSUIT(5))
S PSUR(20)=PSUPO(5)
S PSUR(22)=PSUPO(1)
S PSUR=""
S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'")
S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,"^",I)=PSUR(I)
S PSUR=PSUR_"^"
; Store Records under PSUSNDR default division
S PSURC=PSURC+1,^XTMP(PSUPRSUB,"RECORDS",PSUSNDR,PSURC)=$E(PSUR,1,240) I $L(PSUR)>240 S ^(PSURC,1)=$E(PSUR,241,999)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUPR1 4023 printed Dec 13, 2024@02:28:18 Page 2
PSUPR1 ;BIR/PDW - Data Gathering for PBMS PR file 442 ;12 AUG 1999
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;DBIAs
+3 ; Reference to file #442 supported by DBIA 1020
+4 ; Reference to file #445.01 supported by DBIA 1021
+5 ; Reference to file #420.5 supported by DBIA 1022
+6 ; Reference to file #410 supported by DBIA 2345,2409
+7 ; Reference to file #440 supported by DBIA 2606
+8 ; Reference to file #4.3 supported by DBIA 10091
+9 ; Reference to file #50 supported by DBIA 221
+10 ;
EN ;EP Entry Point
+1 SET PSUEDT=PSUEDT\1+.24
+2 SET PSUPRSDT=PSUSDT
+3 SET PSUPREDT=PSUEDT
+4 ; setup ^XTMP node
+5 if '$DATA(PSUPRJOB)
SET PSUPRJOB=$JOB
+6 if '$DATA(PSUPRSUB)
SET PSUPRSUB="PSUPR_"_PSUPRJOB
+7 IF '$DATA(^XTMP(PSUPRSUB))
Begin DoDot:1
+8 SET ^XTMP(PSUPRSUB,"RECORDS",0)=""
+9 SET X1=DT
SET X2=6
DO C^%DTC
+10 SET ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction"
End DoDot:1
START ;EP
+1 NEW PSUDT,PSUDA
+2 ; record counter
SET PSURC=0
+3 SET PSUDT=PSUPRSDT
+4 FOR
SET PSUDT=$ORDER(^PRC(442,"AB",PSUDT))
if PSUDT'>0
QUIT
if PSUDT>PSUPREDT
QUIT
DO PODATE
+5 QUIT
+6 ;
PODATE ;EP Process a PO DATE
+1 NEW PSUPODA
+2 ; File 442 can not be linked to division so div=sender
+3 ; and indicator = "H"
+4 SET X=$PIECE($GET(^XMB(1,1,"XUS")),U,17)
+5 SET PSUDIV=PSUSNDR
SET PSUDIVI="H"
+6 ; Loop POs within date
+7 SET PSUPODA=0
+8 FOR
SET PSUPODA=$ORDER(^PRC(442,"AB",PSUDT,PSUPODA))
if 'PSUPODA
QUIT
DO PO
+9 QUIT
+10 ;
PO ;EP Process a PO
+1 NEW PSUPO,PSUCC
+2 ; cost center
SET PSUCC=$$VALI^PSUTL(442,PSUPODA,2)
+3 ; not pharmacy related
IF PSUCC'=822400
IF PSUCC'=828100
QUIT
+4 ; supply status
SET PSUSS=$$VALI^PSUTL(442,PSUPODA,.5)
+5 IF PSUSS>14
IF PSUSS<45
+6 ; not within status range
IF '$TEST
QUIT
+7 ; load po information
+8 DO GETS^PSUTL(442,PSUPODA,".01;.1;1;2;5","PSUPO","I")
+9 DO MOVEI^PSUTL("PSUPO")
+10 ;
+11 ; further process po information
+12 ; Vendor name
SET PSUPO(5)=$$VALI^PSUTL(440,PSUPO(5),.01)
+13 ;
+14 ; load item information
+15 KILL ^TMP($JOB,"PSUMIT")
+16 DO GETM^PSUTL(442,PSUPODA,"40*^1;1.5;3;3.1;5;9.3;10;11","^TMP($J,""PSUMIT"")","IN")
+17 DO MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
+18 ;
+19 ; loop items
+20 SET PSUITDA=0
+21 FOR
SET PSUITDA=$ORDER(^TMP($JOB,"PSUMIT",PSUITDA))
if PSUITDA'>0
QUIT
DO ITEM
+22 QUIT
+23 ;
ITEM ;EP Process one item
+1 NEW PSUIT,PSUDRDA
+2 MERGE PSUIT=^TMP($JOB,"PSUMIT",PSUITDA)
+3 ;
+4 ; Get Drug
+5 SET PSUIT(1.5)=+$GET(PSUIT(1.5))
+6 SET PSUDRDA=$ORDER(^PSDRUG("AB",PSUIT(1.5),0))
+7 NEW PSUARSUB,PSUARJOB
SET PSUARSUB=PSUPRSUB
SET PSUARJOB=PSUPRJOB
+8 ; setup drug profile
IF PSUDRDA
DO DRUG^PSUAR2(PSUDRDA)
+9 ;
+10 ; process dispense unit 445 & conversion factor 3.2.6.1.5
+11 SET X=+$GET(PSUIT(10))
SET X=+$$VALI^PSUTL(410,X,4)
+12 ; disp unit
+13 SET PSUIT("DU")=$$VALI^PSUTL(445.01,"X,PSUIT(1.5)",50)
+14 ; disp unit conver factor
+15 SET PSUIT("DUCV")=$$VALI^PSUTL(445.01,"X,PSUIT(1.5)",51)
+16 ; unit of purchase
+17 SET PSUIT("UOP")=$$VALI^PSUTL(420.5,+$GET(PSUIT(3)),.01)
+18 ;
+19 ; further process fields
+20 if '$LENGTH($GET(PSUIT(9.3)))
SET PSUIT(9.3)="No NDC"
+21 ;
+22 ;
REC ;EP Assemble record
+1 KILL PSUR
+2 ; drug reference
SET PSUG="^XTMP(PSUPRSUB,""PSUDRUG_DET"",PSUDRDA)"
+3 SET PSUR(2)=$GET(PSUDIV)
+4 SET PSUR(3)=$GET(PSUDIVI)
+5 SET PSUR(4)=$GET(PSUPO(.1))
+6 IF PSUDRDA
Begin DoDot:1
+7 SET PSUR(5)=@PSUG@(21)
+8 SET PSUR(7)=@PSUG@(.01)
+9 SET PSUR(12)=@PSUG@(14.5)
+10 SET PSUR(6)=@PSUG@(2)
End DoDot:1
+11 IF 'PSUDRDA
Begin DoDot:1
+12 SET PSUR(5)="Unknown VA Product Name"
+13 SET PSUR(7)="Unknown Generic Name"
End DoDot:1
+14 SET PSUR(8)=$GET(PSUIT(1,1))_$GET(PSUIT(1,2))
if '$LENGTH(PSUR(8))
SET PSUR(8)="No description listed"
+15 FOR
SET X=$EXTRACT(PSUR(8))
if X'=" "
QUIT
SET PSUR(8)=$EXTRACT(PSUR(8),2,999)
+16 SET PSUR(8)=$EXTRACT(PSUR(8),1,50)
+17 SET PSUR(9)=$GET(PSUIT(9.3))
+18 SET PSUR(12)=$GET(PSUIT("DU"))
+19 SET PSUR(13)=$GET(PSUIT("UOP"))
+20 SET PSUR(14)=$GET(PSUIT(3.1))
+21 SET PSUR(15)=PSUIT("DU")
+22 SET PSUR(16)=PSUIT("DUCV")
+23 SET PSUR(17)=$GET(PSUIT(11))
+24 SET PSUR(18)=$GET(PSUIT(5))
+25 SET PSUR(19)=$GET(PSUIT(11))*$GET(PSUIT(5))
+26 SET PSUR(20)=PSUPO(5)
+27 SET PSUR(22)=PSUPO(1)
+28 SET PSUR=""
+29 SET I=0
FOR
SET I=$ORDER(PSUR(I))
if I'>0
QUIT
SET PSUR(I)=$TRANSLATE(PSUR(I),"^","'")
+30 SET I=0
FOR
SET I=$ORDER(PSUR(I))
if I'>0
QUIT
SET $PIECE(PSUR,"^",I)=PSUR(I)
+31 SET PSUR=PSUR_"^"
+32 ; Store Records under PSUSNDR default division
+33 SET PSURC=PSURC+1
SET ^XTMP(PSUPRSUB,"RECORDS",PSUSNDR,PSURC)=$EXTRACT(PSUR,1,240)
IF $LENGTH(PSUR)>240
SET ^(PSURC,1)=$EXTRACT(PSUR,241,999)
+34 QUIT
