PSUPR3 ;BIR/PDW - EXTRACTION FROM FILE 58.81 ;12 AUG 1999
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;DBIAs
; Reference to file #58.81 supported by DBIA 2520
; Reference to file #50 supported by DBIA 221
; Reference to file #51.5 supported by DBIA 1931
; Reference to file #58.8 supported by DBIA 2519
; Reference to file #59 supported by DBIA 2510
; Reference to file #42 supported by DBIA 2440
; Reference to file #40.8 supported by DBIA 2438
; Reference to file #59.5 supported by DBIA 2499
;
EN ;EP from PSUPR0
S PSUEDT=PSUEDT\1+.24
; setup ^XTMP node
S:'$D(PSUPRJOB) PSUPRJOB=$J
S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_PSUPRJOB
I '$D(^XTMP(PSUPRSUB)) D
. S ^XTMP(PSUPRSUB,0)=""
. S X1=DT,X2=6 D C^%DTC
. S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^"_" PBMS Procurement Extraction3"
SCANDT ; 3.2.6.31 scan Transaction date time
S PSUDT=PSUSDT
; going after ^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP,PSUTRDA)
;
F S PSUDT=$O(^PSD(58.81,"AF",PSUDT)) Q:PSUDT'>0 Q:PSUDT>PSUEDT D LOC
Q
;
LOC ;EP scan thru locations
;
S PSULOC="" F S PSULOC=$O(^PSD(58.81,"AF",PSUDT,PSULOC)) Q:PSULOC="" D TYPE
Q
;
TYPE ;EP Scan Thru Types
;
S PSUTYP="" F S PSUTYP=$O(^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP)) Q:PSUTYP="" D TRAN
Q
;
TRAN ;EP Scan Thru Transactions
;
S PSUTRDA=0 F S PSUTRDA=$O(^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP,PSUTRDA)) Q:PSUTRDA'>0 D TRANDA
Q
;
TRANDA ;EP work a transaction
;
N PSUTR
D GETS^PSUTL(58.81,PSUTRDA,".01;1;2;3;4;5;8;12;71;106;107","PSUTR","I")
D MOVEI^PSUTL("PSUTR")
S PSUDTDA=PSUTR(3)
; 3.2.6.3.2-3.4
Q:(PSUTR(1)'=1)
I '$D(PSUFLSFG) D
.I $L(PSUTR(8)),'$L($G(PSUTR(71))) Q
I $D(PSUFLSFG) D
.I PSUTR(107)'="" Q
Q:$L(PSUTR(106))
;
; setup file 50 fields
S PSUDRDA=PSUTR(4)
N PSUDRUG
D GETS^PSUTL(50,PSUDRDA,".01;2;12;13;14.5;15;20;21;22;25;31","PSUDRUG","I")
D MOVEI^PSUTL("PSUDRUG")
;
; further process file 50 fields
S:'$L(PSUDRUG(.01)) PSUDRUG(.01)="Unknown Generic Name" ; Generic Name
S:'$L(PSUDRUG(21)) PSUDRUG(21)="Unknown VA Product Name" ; VA Product Name
S:'$L(PSUDRUG(31)) PSUDRUG(31)="No NDC" ; NDC
S PSUDRUG(12)=$$VALI^PSUTL(51.5,PSUDRUG(12),.01) ; Order Unit
;
; setup division 3.2.3.6.3.5
N PSULOC
S PSULOC=PSUTR(2)
; Get division from file 58.8, file 59.7 fileds 90.02,90.03
S PSUDIV="",PSUDIVI="H"
S PSUINV="",PSUINV(4)=PSULOC
D DIV^PSUPR2
CONT ;
I $L(PSUDIV) S PSUDIVI=""
E S PSUDIV=PSUSNDR
;
; Assemble Record
S PSUREC=$$RECORD()
; Store Record
S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
S PSULC=PSULC+1
S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUREC
Q
;
; assemble record
RECORD() ;EP Assemble record for storage
; 3.2.11.38
N PSUR
S PSUR(2)=PSUDIV
S PSUR(3)=PSUDIVI
S PSUR(4)=PSUDTDA\1
S PSUR(5)=PSUDRUG(21)
S PSUR(6)=PSUDRUG(2)
S PSUR(7)=PSUDRUG(.01)
S PSUR(9)=PSUDRUG(31)
S PSUR(12)=PSUDRUG(14.5)
S PSUR(13)=$$VAL^PSUTL(50,PSUDRDA,12)
S PSUR(16)=PSUDRUG(15)
S PSUR(17)=PSUTR(5)
S PSUR(18)=PSUDRUG(13)
I PSUDRUG(15) S PSUR(360)=PSUDRUG(13)*(PSUTR(5)/PSUDRUG(15))
E S PSUR(360)=""
S PSUR(19)=$J(PSUR(360),12,2)
K PSUR(360)
S PSUR(20)=PSUTR(12)
S PSUR(21)=PSUTR(71)
S PSUR(22)=""
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_"^"
Q PSUR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUPR3 3453 printed Sep 23, 2025@20:03:59 Page 2
PSUPR3 ;BIR/PDW - EXTRACTION FROM FILE 58.81 ;12 AUG 1999
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;DBIAs
+3 ; Reference to file #58.81 supported by DBIA 2520
+4 ; Reference to file #50 supported by DBIA 221
+5 ; Reference to file #51.5 supported by DBIA 1931
+6 ; Reference to file #58.8 supported by DBIA 2519
+7 ; Reference to file #59 supported by DBIA 2510
+8 ; Reference to file #42 supported by DBIA 2440
+9 ; Reference to file #40.8 supported by DBIA 2438
+10 ; Reference to file #59.5 supported by DBIA 2499
+11 ;
EN ;EP from PSUPR0
+1 SET PSUEDT=PSUEDT\1+.24
+2 ; setup ^XTMP node
+3 if '$DATA(PSUPRJOB)
SET PSUPRJOB=$JOB
+4 if '$DATA(PSUPRSUB)
SET PSUPRSUB="PSUPR_"_PSUPRJOB
+5 IF '$DATA(^XTMP(PSUPRSUB))
Begin DoDot:1
+6 SET ^XTMP(PSUPRSUB,0)=""
+7 SET X1=DT
SET X2=6
DO C^%DTC
+8 SET ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^"_" PBMS Procurement Extraction3"
End DoDot:1
SCANDT ; 3.2.6.31 scan Transaction date time
+1 SET PSUDT=PSUSDT
+2 ; going after ^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP,PSUTRDA)
+3 ;
+4 FOR
SET PSUDT=$ORDER(^PSD(58.81,"AF",PSUDT))
if PSUDT'>0
QUIT
if PSUDT>PSUEDT
QUIT
DO LOC
+5 QUIT
+6 ;
LOC ;EP scan thru locations
+1 ;
+2 SET PSULOC=""
FOR
SET PSULOC=$ORDER(^PSD(58.81,"AF",PSUDT,PSULOC))
if PSULOC=""
QUIT
DO TYPE
+3 QUIT
+4 ;
TYPE ;EP Scan Thru Types
+1 ;
+2 SET PSUTYP=""
FOR
SET PSUTYP=$ORDER(^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP))
if PSUTYP=""
QUIT
DO TRAN
+3 QUIT
+4 ;
TRAN ;EP Scan Thru Transactions
+1 ;
+2 SET PSUTRDA=0
FOR
SET PSUTRDA=$ORDER(^PSD(58.81,"AF",PSUDT,PSULOC,PSUTYP,PSUTRDA))
if PSUTRDA'>0
QUIT
DO TRANDA
+3 QUIT
+4 ;
TRANDA ;EP work a transaction
+1 ;
+2 NEW PSUTR
+3 DO GETS^PSUTL(58.81,PSUTRDA,".01;1;2;3;4;5;8;12;71;106;107","PSUTR","I")
+4 DO MOVEI^PSUTL("PSUTR")
+5 SET PSUDTDA=PSUTR(3)
+6 ; 3.2.6.3.2-3.4
+7 if (PSUTR(1)'=1)
QUIT
+8 IF '$DATA(PSUFLSFG)
Begin DoDot:1
+9 IF $LENGTH(PSUTR(8))
IF '$LENGTH($GET(PSUTR(71)))
QUIT
End DoDot:1
+10 IF $DATA(PSUFLSFG)
Begin DoDot:1
+11 IF PSUTR(107)'=""
QUIT
End DoDot:1
+12 if $LENGTH(PSUTR(106))
QUIT
+13 ;
+14 ; setup file 50 fields
+15 SET PSUDRDA=PSUTR(4)
+16 NEW PSUDRUG
+17 DO GETS^PSUTL(50,PSUDRDA,".01;2;12;13;14.5;15;20;21;22;25;31","PSUDRUG","I")
+18 DO MOVEI^PSUTL("PSUDRUG")
+19 ;
+20 ; further process file 50 fields
+21 ; Generic Name
if '$LENGTH(PSUDRUG(.01))
SET PSUDRUG(.01)="Unknown Generic Name"
+22 ; VA Product Name
if '$LENGTH(PSUDRUG(21))
SET PSUDRUG(21)="Unknown VA Product Name"
+23 ; NDC
if '$LENGTH(PSUDRUG(31))
SET PSUDRUG(31)="No NDC"
+24 ; Order Unit
SET PSUDRUG(12)=$$VALI^PSUTL(51.5,PSUDRUG(12),.01)
+25 ;
+26 ; setup division 3.2.3.6.3.5
+27 NEW PSULOC
+28 SET PSULOC=PSUTR(2)
+29 ; Get division from file 58.8, file 59.7 fileds 90.02,90.03
+30 SET PSUDIV=""
SET PSUDIVI="H"
+31 SET PSUINV=""
SET PSUINV(4)=PSULOC
+32 DO DIV^PSUPR2
CONT ;
+1 IF $LENGTH(PSUDIV)
SET PSUDIVI=""
+2 IF '$TEST
SET PSUDIV=PSUSNDR
+3 ;
+4 ; Assemble Record
+5 SET PSUREC=$$RECORD()
+6 ; Store Record
+7 SET PSULC=+$ORDER(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
+8 SET PSULC=PSULC+1
+9 SET ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUREC
+10 QUIT
+11 ;
+12 ; assemble record
RECORD() ;EP Assemble record for storage
+1 ; 3.2.11.38
+2 NEW PSUR
+3 SET PSUR(2)=PSUDIV
+4 SET PSUR(3)=PSUDIVI
+5 SET PSUR(4)=PSUDTDA\1
+6 SET PSUR(5)=PSUDRUG(21)
+7 SET PSUR(6)=PSUDRUG(2)
+8 SET PSUR(7)=PSUDRUG(.01)
+9 SET PSUR(9)=PSUDRUG(31)
+10 SET PSUR(12)=PSUDRUG(14.5)
+11 SET PSUR(13)=$$VAL^PSUTL(50,PSUDRDA,12)
+12 SET PSUR(16)=PSUDRUG(15)
+13 SET PSUR(17)=PSUTR(5)
+14 SET PSUR(18)=PSUDRUG(13)
+15 IF PSUDRUG(15)
SET PSUR(360)=PSUDRUG(13)*(PSUTR(5)/PSUDRUG(15))
+16 IF '$TEST
SET PSUR(360)=""
+17 SET PSUR(19)=$JUSTIFY(PSUR(360),12,2)
+18 KILL PSUR(360)
+19 SET PSUR(20)=PSUTR(12)
+20 SET PSUR(21)=PSUTR(71)
+21 SET PSUR(22)=""
+22 SET I=0
FOR
SET I=$ORDER(PSUR(I))
if I'>0
QUIT
SET PSUR(I)=$TRANSLATE(PSUR(I),"^","'")
+23 SET I=0
FOR
SET I=$ORDER(PSUR(I))
if I'>0
QUIT
SET $PIECE(PSUR,"^",I)=PSUR(I)
+24 SET PSUR=PSUR_"^"
+25 QUIT PSUR
