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

PSUPR3.m

Go to the documentation of this file.
  1. PSUPR3 ;BIR/PDW - EXTRACTION FROM FILE 58.81 ;12 AUG 1999
  1. ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  1. ;DBIAs
  1. ; Reference to file #58.81 supported by DBIA 2520
  1. ; Reference to file #50 supported by DBIA 221
  1. ; Reference to file #51.5 supported by DBIA 1931
  1. ; Reference to file #58.8 supported by DBIA 2519
  1. ; Reference to file #59 supported by DBIA 2510
  1. ; Reference to file #42 supported by DBIA 2440
  1. ; Reference to file #40.8 supported by DBIA 2438
  1. ; Reference to file #59.5 supported by DBIA 2499
  1. ;
  1. EN ;EP from PSUPR0
  1. S PSUEDT=PSUEDT\1+.24
  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,0)=""
  1. . S X1=DT,X2=6 D C^%DTC
  1. . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^"_" PBMS Procurement Extraction3"
  1. SCANDT ; 3.2.6.31 scan Transaction date time
  1. S PSUDT=PSUSDT
  1. ; going after ^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP,PSUTRDA)
  1. ;
  1. F S PSUDT=$O(^PSD(58.81,"AF",PSUDT)) Q:PSUDT'>0 Q:PSUDT>PSUEDT D LOC
  1. Q
  1. ;
  1. LOC ;EP scan thru locations
  1. ;
  1. S PSULOC="" F S PSULOC=$O(^PSD(58.81,"AF",PSUDT,PSULOC)) Q:PSULOC="" D TYPE
  1. Q
  1. ;
  1. TYPE ;EP Scan Thru Types
  1. ;
  1. S PSUTYP="" F S PSUTYP=$O(^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP)) Q:PSUTYP="" D TRAN
  1. Q
  1. ;
  1. TRAN ;EP Scan Thru Transactions
  1. ;
  1. S PSUTRDA=0 F S PSUTRDA=$O(^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP,PSUTRDA)) Q:PSUTRDA'>0 D TRANDA
  1. Q
  1. ;
  1. TRANDA ;EP work a transaction
  1. ;
  1. N PSUTR
  1. D GETS^PSUTL(58.81,PSUTRDA,".01;1;2;3;4;5;8;12;71;106;107","PSUTR","I")
  1. D MOVEI^PSUTL("PSUTR")
  1. S PSUDTDA=PSUTR(3)
  1. ; 3.2.6.3.2-3.4
  1. Q:(PSUTR(1)'=1)
  1. I '$D(PSUFLSFG) D
  1. .I $L(PSUTR(8)),'$L($G(PSUTR(71))) Q
  1. I $D(PSUFLSFG) D
  1. .I PSUTR(107)'="" Q
  1. Q:$L(PSUTR(106))
  1. ;
  1. ; setup file 50 fields
  1. S PSUDRDA=PSUTR(4)
  1. N PSUDRUG
  1. D GETS^PSUTL(50,PSUDRDA,".01;2;12;13;14.5;15;20;21;22;25;31","PSUDRUG","I")
  1. D MOVEI^PSUTL("PSUDRUG")
  1. ;
  1. ; further process file 50 fields
  1. S:'$L(PSUDRUG(.01)) PSUDRUG(.01)="Unknown Generic Name" ; Generic Name
  1. S:'$L(PSUDRUG(21)) PSUDRUG(21)="Unknown VA Product Name" ; VA Product Name
  1. S:'$L(PSUDRUG(31)) PSUDRUG(31)="No NDC" ; NDC
  1. S PSUDRUG(12)=$$VALI^PSUTL(51.5,PSUDRUG(12),.01) ; Order Unit
  1. ;
  1. ; setup division 3.2.3.6.3.5
  1. N PSULOC
  1. S PSULOC=PSUTR(2)
  1. ; Get division from file 58.8, file 59.7 fileds 90.02,90.03
  1. S PSUDIV="",PSUDIVI="H"
  1. S PSUINV="",PSUINV(4)=PSULOC
  1. D DIV^PSUPR2
  1. CONT ;
  1. I $L(PSUDIV) S PSUDIVI=""
  1. E S PSUDIV=PSUSNDR
  1. ;
  1. ; Assemble Record
  1. S PSUREC=$$RECORD()
  1. ; Store Record
  1. S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
  1. S PSULC=PSULC+1
  1. S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUREC
  1. Q
  1. ;
  1. ; assemble record
  1. RECORD() ;EP Assemble record for storage
  1. ; 3.2.11.38
  1. N PSUR
  1. S PSUR(2)=PSUDIV
  1. S PSUR(3)=PSUDIVI
  1. S PSUR(4)=PSUDTDA\1
  1. S PSUR(5)=PSUDRUG(21)
  1. S PSUR(6)=PSUDRUG(2)
  1. S PSUR(7)=PSUDRUG(.01)
  1. S PSUR(9)=PSUDRUG(31)
  1. S PSUR(12)=PSUDRUG(14.5)
  1. S PSUR(13)=$$VAL^PSUTL(50,PSUDRDA,12)
  1. S PSUR(16)=PSUDRUG(15)
  1. S PSUR(17)=PSUTR(5)
  1. S PSUR(18)=PSUDRUG(13)
  1. I PSUDRUG(15) S PSUR(360)=PSUDRUG(13)*(PSUTR(5)/PSUDRUG(15))
  1. E S PSUR(360)=""
  1. S PSUR(19)=$J(PSUR(360),12,2)
  1. K PSUR(360)
  1. S PSUR(20)=PSUTR(12)
  1. S PSUR(21)=PSUTR(71)
  1. S PSUR(22)=""
  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. Q PSUR