- 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 Jan 18, 2025@03:28:59 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