Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSUPR1

PSUPR1.m

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