- 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 Jan 18, 2025@03:29:01 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