- PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ; 1/10/11 7:20am
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13,18**;MARCH, 2005;Build 7
- ;DBIAs
- ; Reference to file #58.811 supported by DBIA 2521
- ; Reference to file #51.5 supported by DBIA 1931
- ; Reference to file #50 supported by DBIA 221
- ; Reference to file #58.8 supported by DBIA 2519
- ; 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
- ; Reference to file #59 supported by DBIA 2510
- ;
- EN ;
- S PSUEND=PSUEDT
- S PSUEDT=PSUEDT\1+.24
- S:'$D(PSUPRJOB) PSUPRJOB=$J
- S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J
- 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"
- ;
- S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
- D MAP
- ;
- ; check for Drug Accountability
- S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY")
- I 'X Q ; not installed
- ;
- S X1=PSUSDT,X2=-45 ;backup by 45 days per revision
- D C^%DTC
- S PSUDT=X
- ; loop thru invoice date field xref
- F S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT Q:PSUDT'>0 D
- . S PSUORDA=0 F S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0 D
- .. S PSUINVDA=0 F S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0 D INVOICE
- Q
- ;
- INVOICE ;EP process an invoice within an order
- N PSUSTAT
- S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2)
- I PSUSTAT'="C" Q ; 3.2.6.1
- N PSUORD
- D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD")
- ;
- S PSUINV=""
- N PSURDT,PSUIVNUM
- D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I")
- D MOVEI^PSUTL("PSUINV")
- S PSURDT=PSUINV(8)
- S PSUIVNUM=PSUINV(.01)
- ;
- ;*18 Clear out Division for each invoice.
- S PSUDIV=""
- I $G(PSUINV(4)) D DIV
- I $L(PSUDIV) S PSUDIVI=""
- E S PSUDIV=PSUSNDR,PSUDIVI="H"
- ;
- ;
- K ^TMP($J,"PSUMIT") ; array for multiple items
- D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I")
- I '$D(^TMP($J,"PSUMIT")) Q ;
- D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
- ;
- S PSUITDA=0 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM
- Q
- ITEM ;EP process one item within the invoice
- N PSUIT ; array for one item
- M PSUIT=^TMP($J,"PSUMIT",PSUITDA)
- ;
- I (PSUIT(7)<PSUSDT) Q
- I (PSUIT(7)>PSUEDT) Q
- ; pull adjustments 3.2.6.2.8
- N PSUMADJ
- D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I")
- I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ")
- ;
- ;
- ; Review/Process Adjustments
- I $D(PSUMADJ) S PSUADJDA=0 F S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0 D
- . N PSUADJ
- . M PSUADJ=PSUMADJ(PSUADJDA)
- . ;
- . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5) ; 3.2.6.2.8 Drug or Supply
- . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5) ; 3.2.6.2.11 OrderUnits
- . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5) ; 3.2.6.2.12 Price
- . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity
- . Q
- ;
- I 'PSUIT(2) Q ; per Lina 10/7/98 if qty = 0 don't send record
- ; work on the order unit PSUIT(3)
- I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina
- I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11
- ;
- ; further process item fields 3.2.6.2.9 +
- ;
- ; look for/ construct Dispense Units per Order Unit
- ; Store in PSUIT(9999) 3.2.6.2.13
- ; Get Related Drug Fields 3.2.6.2.9
- ;
- N PSUDRUG
- S PSUDRDA=0
- ; if PSUIT(1) is a supply item the following will not be computed
- I PSUIT(1)=+PSUIT(1) D
- . S PSUDRDA=PSUIT(1)
- . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
- . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I")
- . D MOVEI^PSUTL("PSUDRUG")
- . S PSUIT(1)=PSUDRUG(.01) ; Generic Name
- . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name"
- . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC"
- ; further process fields
- ; fill in drug fields for supply items
- I 'PSUDRDA D
- . S PSUDRUG(.01)="Unknown Generic Name"
- . S PSUDRUG(21)="Unknown VA Product Name"
- . S PSUDRUG(31)="No NDC"
- ;
- ; NDC
- I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC"
- ;
- ; dispense units per order unit 3.2.6.2.13
- ;
- S PSUIT(9999)=0
- I $L(PSUIT(13)),$G(PSUDRDA) D
- . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,""))
- . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403")
- ;
- I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina
- ;
- ;PSU*4*13 Comment out To prevent XINDEX from complaining about
- ; ^PSUPR7 (CoreFLS remnance)
- ;Create "RECORDS" global for CoreFLS data
- ;I $D(PSUFLSFG) S PSUA="" D
- ;.F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7
- ;
- ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC)
- S PSUR=$$RECORD()
- ; Store Records by Division
- S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
- S PSULC=PSULC+1
- S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR
- Q
- ;
- RECORD() ;EP Assemble record
- N PSUR
- S PSUR(2)=$G(PSUDIV)
- S PSUR(3)=$G(PSUDIVI)
- S PSUR(4)=PSUIT(7)\1 ; 3.2.6.2.2
- S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9
- S PSUR(6)=$G(PSUDRUG(2)) ; ""
- S PSUR(7)=PSUIT(1) ; 3.2.6.2.8
- S PSUR(9)=PSUIT(13) ; 3.2.6.2.9
- S PSUR(10)=PSUIT(14) ; ""
- S PSUR(11)=PSUIT(15) ; ""
- S PSUR(12)=$G(PSUDRUG(14.5)) ; ""
- S PSUR(13)=PSUIT(3) ; 3.2.6.2.11
- S PSUR(16)=PSUIT(9999) ; 3.2.6.2.13
- S PSUR(17)=PSUIT(2) ; 3.2.6.2.10
- S PSUR(18)=PSUIT(4) ; 3.2.6.2.12
- S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14
- S PSUR(20)=PSUORD(1) ; 3.2.6.2.5
- S PSUR(21)=PSUINV(.01) ; 3.2.6.2.6
- S PSUR(22)=""
- 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,U,I)=PSUR(I)
- S PSUR=PSUR_U
- Q PSUR
- ;
- DIV ;Find division or outpatient site
- ;
- S PSUDIV=""
- N MAPLOCI
- D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I")
- D MOVEMI^PSUTL("MAPLOCI")
- ;
- I $G(MAPLOCI(PSUINV(4),.01)) D
- .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
- .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
- I '$G(MAPLOCI(PSUINV(4),.01)) D
- .S PSUDIV=PSUSNDR
- .S PSUDIVI="H"
- Q
- ;
- ;
- MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy
- ;Location is mapped to a division or outpatient site. If it is not
- ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a
- ;global to be mailed to the user.
- ;
- K NAOU,DAPH
- K MAPLOCI,MAPLOC
- S PSUNAM=0 ;This is the name of the NAOU or DA PHARMACY
- ;
- F S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM="" D
- .S IEN=0
- .F S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN="" D
- ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)")
- ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN)
- ..D MAP1
- ;
- Q
- ;
- MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks
- ;to see if it is in file 59.7, field 90.02 or 90.03.
- ;
- ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is
- ;no value in subfield .02 or .03, then an NAOU has not been mapped.
- ;
- ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is
- ;no value in subfield .02 or .03, then a DA PHARMACY location has not
- ;been mapped.
- ;
- ;Keep only the entries that are NOT mapped
- ;
- N PSUDA
- ;
- ;Look for unmapped NAOU's
- ;I $G(NAOU(IEN),1) D
- I $G(^PS(59.7,1,90.02,IEN,0)) D
- .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI")
- .S PSUDA=0
- .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D
- ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA)
- ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA)
- M ^XTMP(PSUARSUB,"NAOU")=NAOU ;only unmapped NAOU locations.
- ;
- ;
- ;Look for unmapped DA PHARM
- I $G(^PS(59.7,1,90.03,IEN,0)) D
- .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC")
- .S PSUDA=0
- .F S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA="" D
- ..;PSU*4*13 Correct Problm DA Pharm Report
- ..I $G(MAPLOC(PSUDA,.02))'="" K DAPH(PSUDA)
- ..I $G(MAPLOC(PSUDA,.03))'="" K DAPH(PSUDA)
- M ^XTMP(PSUARSUB,"DAPH")=DAPH ;only unmapped DA PHARM locations.
- Q
- ;
- WRD() ;EP Process for ward;
- N PSUWD,PSUWDDA,PSUDIV
- S PSUDIV=""
- D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I")
- D MOVEMI^PSUTL("PSUWD")
- ; loop ward pointers
- S PSUWDDA=0
- F S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0 D Q:$L(PSUDIV)
- . S X=$$VALI^PSUTL(42,PSUWDDA,.015)
- . Q:'X
- . S X=$$VALI^PSUTL(40.8,X,1)
- . I $L(X) S PSUDIV=X
- ; return value of PSUDIV "" or = facility number
- Q PSUDIV
- ;
- INP() ;EP Process for Inpatient
- ; within package call to AR/WS that pulls/builds Inpatient AOU Site
- ; uses IEN Value to AOU STATs file 58.5
- N PSUARSUB,PSUARJOB
- S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2)
- N PSULOC
- S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB
- S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found
- S:X="NULL" X=""
- Q X
- ;
- IV() ;EP Process,PSUIVDA for IV
- ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY)
- N PSUIV,PSUDIV
- S PSUDIV=""
- D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I")
- D MOVEMI^PSUTL("PSUIV")
- S PSUIVDA=0
- F S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0 D Q:$L(PSUDIV)
- . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02)
- . I X S X=$$VALI^PSUTL(40.8,X,1)
- . I $L(X) S PSUDIV=X
- ;
- Q PSUDIV
- ;
- OUT() ;EP Process for Outpatient
- S X=$$VALI^PSUTL(58.8,PSULOC,20)
- I X S X=$$VALI^PSUTL(59,X,.06)
- Q X
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUPR2 9429 printed Jan 18, 2025@03:29 Page 2
- PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ; 1/10/11 7:20am
- +1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13,18**;MARCH, 2005;Build 7
- +2 ;DBIAs
- +3 ; Reference to file #58.811 supported by DBIA 2521
- +4 ; Reference to file #51.5 supported by DBIA 1931
- +5 ; Reference to file #50 supported by DBIA 221
- +6 ; Reference to file #58.8 supported by DBIA 2519
- +7 ; Reference to file #42 supported by DBIA 2440
- +8 ; Reference to file #40.8 supported by DBIA 2438
- +9 ; Reference to file #59.5 supported by DBIA 2499
- +10 ; Reference to file #59 supported by DBIA 2510
- +11 ;
- EN ;
- +1 SET PSUEND=PSUEDT
- +2 SET PSUEDT=PSUEDT\1+.24
- +3 if '$DATA(PSUPRJOB)
- SET PSUPRJOB=$JOB
- +4 if '$DATA(PSUPRSUB)
- SET PSUPRSUB="PSUPR_"_$JOB
- +5 IF '$DATA(^XTMP(PSUPRSUB))
- Begin DoDot:1
- +6 SET ^XTMP(PSUPRSUB,"RECORDS",0)=""
- +7 SET X1=DT
- SET X2=6
- DO C^%DTC
- +8 SET ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction"
- End DoDot:1
- +9 ;
- +10 SET PSUARJOB=PSUPRJOB
- SET PSUARSUB="PSUAR_"_PSUARJOB
- +11 DO MAP
- +12 ;
- +13 ; check for Drug Accountability
- +14 SET X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY")
- +15 ; not installed
- IF 'X
- QUIT
- +16 ;
- +17 ;backup by 45 days per revision
- SET X1=PSUSDT
- SET X2=-45
- +18 DO C^%DTC
- +19 SET PSUDT=X
- +20 ; loop thru invoice date field xref
- +21 FOR
- SET PSUDT=$ORDER(^PSD(58.811,"ADATE",PSUDT))
- if PSUDT>PSUEDT
- QUIT
- if PSUDT'>0
- QUIT
- Begin DoDot:1
- +22 SET PSUORDA=0
- FOR
- SET PSUORDA=$ORDER(^PSD(58.811,"ADATE",PSUDT,PSUORDA))
- if PSUORDA'>0
- QUIT
- Begin DoDot:2
- +23 SET PSUINVDA=0
- FOR
- SET PSUINVDA=$ORDER(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA))
- if PSUINVDA'>0
- QUIT
- DO INVOICE
- End DoDot:2
- End DoDot:1
- +24 QUIT
- +25 ;
- INVOICE ;EP process an invoice within an order
- +1 NEW PSUSTAT
- +2 SET PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2)
- +3 ; 3.2.6.1
- IF PSUSTAT'="C"
- QUIT
- +4 NEW PSUORD
- +5 DO GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD")
- +6 ;
- +7 SET PSUINV=""
- +8 NEW PSURDT,PSUIVNUM
- +9 DO GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I")
- +10 DO MOVEI^PSUTL("PSUINV")
- +11 SET PSURDT=PSUINV(8)
- +12 SET PSUIVNUM=PSUINV(.01)
- +13 ;
- +14 ;*18 Clear out Division for each invoice.
- +15 SET PSUDIV=""
- +16 IF $GET(PSUINV(4))
- DO DIV
- +17 IF $LENGTH(PSUDIV)
- SET PSUDIVI=""
- +18 IF '$TEST
- SET PSUDIV=PSUSNDR
- SET PSUDIVI="H"
- +19 ;
- +20 ;
- +21 ; array for multiple items
- KILL ^TMP($JOB,"PSUMIT")
- +22 DO GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I")
- +23 ;
- IF '$DATA(^TMP($JOB,"PSUMIT"))
- QUIT
- +24 DO MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
- +25 ;
- +26 SET PSUITDA=0
- FOR
- SET PSUITDA=$ORDER(^TMP($JOB,"PSUMIT",PSUITDA))
- if PSUITDA'>0
- QUIT
- DO ITEM
- +27 QUIT
- ITEM ;EP process one item within the invoice
- +1 ; array for one item
- NEW PSUIT
- +2 MERGE PSUIT=^TMP($JOB,"PSUMIT",PSUITDA)
- +3 ;
- +4 IF (PSUIT(7)<PSUSDT)
- QUIT
- +5 IF (PSUIT(7)>PSUEDT)
- QUIT
- +6 ; pull adjustments 3.2.6.2.8
- +7 NEW PSUMADJ
- +8 DO GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I")
- +9 IF $DATA(PSUMADJ)
- DO MOVEMI^PSUTL("PSUMADJ")
- +10 ;
- +11 ;
- +12 ; Review/Process Adjustments
- +13 IF $DATA(PSUMADJ)
- SET PSUADJDA=0
- FOR
- SET PSUADJDA=$ORDER(PSUMADJ(PSUADJDA))
- if PSUADJDA'>0
- QUIT
- Begin DoDot:1
- +14 NEW PSUADJ
- +15 MERGE PSUADJ=PSUMADJ(PSUADJDA)
- +16 ;
- +17 ; 3.2.6.2.8 Drug or Supply
- IF PSUADJ(.01)="D"
- SET PSUIT(1)=PSUADJ(5)
- +18 ; 3.2.6.2.11 OrderUnits
- IF PSUADJ(.01)="O"
- SET PSUIT(3)=PSUADJ(5)
- +19 ; 3.2.6.2.12 Price
- IF PSUADJ(.01)="P"
- SET PSUIT(4)=PSUADJ(5)
- +20 ; 3.2.6.2.10 Quantity
- IF PSUADJ(.01)="Q"
- SET PSUIT(2)=PSUIT(2)+PSUADJ(5)
- +21 QUIT
- End DoDot:1
- +22 ;
- +23 ; per Lina 10/7/98 if qty = 0 don't send record
- IF 'PSUIT(2)
- QUIT
- +24 ; work on the order unit PSUIT(3)
- +25 ; per Lina
- IF '$DATA(PSUADJ)
- IF +PSUIT(3)=0
- SET PSUIT(3)=""
- +26 ; 3.2.6.2.11
- IF PSUIT(3)
- SET PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01)
- +27 ;
- +28 ; further process item fields 3.2.6.2.9 +
- +29 ;
- +30 ; look for/ construct Dispense Units per Order Unit
- +31 ; Store in PSUIT(9999) 3.2.6.2.13
- +32 ; Get Related Drug Fields 3.2.6.2.9
- +33 ;
- +34 NEW PSUDRUG
- +35 SET PSUDRDA=0
- +36 ; if PSUIT(1) is a supply item the following will not be computed
- +37 IF PSUIT(1)=+PSUIT(1)
- Begin DoDot:1
- +38 SET PSUDRDA=PSUIT(1)
- +39 ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
- +40 DO GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I")
- +41 DO MOVEI^PSUTL("PSUDRUG")
- +42 ; Generic Name
- SET PSUIT(1)=PSUDRUG(.01)
- +43 if PSUDRUG(21)=""
- SET PSUDRUG(21)="Unknown VA Product Name"
- +44 if PSUDRUG(31)=""
- SET PSUDRUG(31)="No NDC"
- End DoDot:1
- +45 ; further process fields
- +46 ; fill in drug fields for supply items
- +47 IF 'PSUDRDA
- Begin DoDot:1
- +48 SET PSUDRUG(.01)="Unknown Generic Name"
- +49 SET PSUDRUG(21)="Unknown VA Product Name"
- +50 SET PSUDRUG(31)="No NDC"
- End DoDot:1
- +51 ;
- +52 ; NDC
- +53 IF PSUIT(13)=""
- SET PSUIT(13)=$GET(PSUDRUG(31))
- if PSUIT(13)=""
- SET PSUIT(13)="No NDC"
- +54 ;
- +55 ; dispense units per order unit 3.2.6.2.13
- +56 ;
- +57 SET PSUIT(9999)=0
- +58 IF $LENGTH(PSUIT(13))
- IF $GET(PSUDRDA)
- Begin DoDot:1
- +59 SET X=$ORDER(^PSDRUG("C",PSUIT(13),PSUDRDA,""))
- +60 IF X
- SET PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403")
- End DoDot:1
- +61 ;
- +62 ; per Lina
- IF '$DATA(PSUADJ)
- IF 'PSUIT(9999)
- SET PSUIT(9999)=""
- +63 ;
- +64 ;PSU*4*13 Comment out To prevent XINDEX from complaining about
- +65 ; ^PSUPR7 (CoreFLS remnance)
- +66 ;Create "RECORDS" global for CoreFLS data
- +67 ;I $D(PSUFLSFG) S PSUA="" D
- +68 ;.F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7
- +69 ;
- +70 ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC)
- +71 SET PSUR=$$RECORD()
- +72 ; Store Records by Division
- +73 SET PSULC=+$ORDER(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
- +74 SET PSULC=PSULC+1
- +75 SET ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR
- +76 QUIT
- +77 ;
- RECORD() ;EP Assemble record
- +1 NEW PSUR
- +2 SET PSUR(2)=$GET(PSUDIV)
- +3 SET PSUR(3)=$GET(PSUDIVI)
- +4 ; 3.2.6.2.2
- SET PSUR(4)=PSUIT(7)\1
- +5 ; 3.2.6.2.9
- SET PSUR(5)=$GET(PSUDRUG(21))
- +6 ; ""
- SET PSUR(6)=$GET(PSUDRUG(2))
- +7 ; 3.2.6.2.8
- SET PSUR(7)=PSUIT(1)
- +8 ; 3.2.6.2.9
- SET PSUR(9)=PSUIT(13)
- +9 ; ""
- SET PSUR(10)=PSUIT(14)
- +10 ; ""
- SET PSUR(11)=PSUIT(15)
- +11 ; ""
- SET PSUR(12)=$GET(PSUDRUG(14.5))
- +12 ; 3.2.6.2.11
- SET PSUR(13)=PSUIT(3)
- +13 ; 3.2.6.2.13
- SET PSUR(16)=PSUIT(9999)
- +14 ; 3.2.6.2.10
- SET PSUR(17)=PSUIT(2)
- +15 ; 3.2.6.2.12
- SET PSUR(18)=PSUIT(4)
- +16 ; 3.2.6.2.14
- SET PSUR(19)=PSUR(17)*PSUR(18)
- +17 ; 3.2.6.2.5
- SET PSUR(20)=PSUORD(1)
- +18 ; 3.2.6.2.6
- SET PSUR(21)=PSUINV(.01)
- +19 SET PSUR(22)=""
- +20 SET PSUR=""
- +21 SET I=0
- FOR
- SET I=$ORDER(PSUR(I))
- if I'>0
- QUIT
- SET PSUR(I)=$TRANSLATE(PSUR(I),"^","'")
- +22 SET I=0
- FOR
- SET I=$ORDER(PSUR(I))
- if I'>0
- QUIT
- SET $PIECE(PSUR,U,I)=PSUR(I)
- +23 SET PSUR=PSUR_U
- +24 QUIT PSUR
- +25 ;
- DIV ;Find division or outpatient site
- +1 ;
- +2 SET PSUDIV=""
- +3 NEW MAPLOCI
- +4 DO GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I")
- +5 DO MOVEMI^PSUTL("MAPLOCI")
- +6 ;
- +7 IF $GET(MAPLOCI(PSUINV(4),.01))
- Begin DoDot:1
- +8 SET X=$GET(MAPLOCI(PSUINV(4),.02))
- IF X
- SET PSUDIV=$$VALI^PSUTL(40.8,X,1)
- +9 SET X=$GET(MAPLOCI(PSUINV(4),.03))
- IF X
- SET PSUDIV=$$VALI^PSUTL(59,X,.06)
- End DoDot:1
- +10 IF '$GET(MAPLOCI(PSUINV(4),.01))
- Begin DoDot:1
- +11 SET PSUDIV=PSUSNDR
- +12 SET PSUDIVI="H"
- End DoDot:1
- +13 QUIT
- +14 ;
- +15 ;
- MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy
- +1 ;Location is mapped to a division or outpatient site. If it is not
- +2 ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a
- +3 ;global to be mailed to the user.
- +4 ;
- +5 KILL NAOU,DAPH
- +6 KILL MAPLOCI,MAPLOC
- +7 ;This is the name of the NAOU or DA PHARMACY
- SET PSUNAM=0
- +8 ;
- +9 FOR
- SET PSUNAM=$ORDER(^PSD(58.8,"B",PSUNAM))
- if PSUNAM=""
- QUIT
- Begin DoDot:1
- +10 SET IEN=0
- +11 FOR
- SET IEN=$ORDER(^PSD(58.8,"B",PSUNAM,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +12 DO GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)")
- +13 IF NAOU(IEN,1)="PRIMARY"
- MERGE DAPH(IEN)=NAOU(IEN)
- KILL NAOU(IEN)
- +14 DO MAP1
- End DoDot:2
- End DoDot:1
- +15 ;
- +16 QUIT
- +17 ;
- MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks
- +1 ;to see if it is in file 59.7, field 90.02 or 90.03.
- +2 ;
- +3 ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is
- +4 ;no value in subfield .02 or .03, then an NAOU has not been mapped.
- +5 ;
- +6 ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is
- +7 ;no value in subfield .02 or .03, then a DA PHARMACY location has not
- +8 ;been mapped.
- +9 ;
- +10 ;Keep only the entries that are NOT mapped
- +11 ;
- +12 NEW PSUDA
- +13 ;
- +14 ;Look for unmapped NAOU's
- +15 ;I $G(NAOU(IEN),1) D
- +16 IF $GET(^PS(59.7,1,90.02,IEN,0))
- Begin DoDot:1
- +17 DO GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI")
- +18 SET PSUDA=0
- +19 FOR
- SET PSUDA=$ORDER(MAPLOCI(PSUDA))
- if PSUDA=""
- QUIT
- Begin DoDot:2
- +20 IF MAPLOCI(PSUDA,.02)'=""
- KILL NAOU(PSUDA)
- +21 IF MAPLOCI(PSUDA,.03)'=""
- KILL NAOU(PSUDA)
- End DoDot:2
- End DoDot:1
- +22 ;only unmapped NAOU locations.
- MERGE ^XTMP(PSUARSUB,"NAOU")=NAOU
- +23 ;
- +24 ;
- +25 ;Look for unmapped DA PHARM
- +26 IF $GET(^PS(59.7,1,90.03,IEN,0))
- Begin DoDot:1
- +27 DO GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC")
- +28 SET PSUDA=0
- +29 FOR
- SET PSUDA=$ORDER(MAPLOC(PSUDA))
- if PSUDA=""
- QUIT
- Begin DoDot:2
- +30 ;PSU*4*13 Correct Problm DA Pharm Report
- +31 IF $GET(MAPLOC(PSUDA,.02))'=""
- KILL DAPH(PSUDA)
- +32 IF $GET(MAPLOC(PSUDA,.03))'=""
- KILL DAPH(PSUDA)
- End DoDot:2
- End DoDot:1
- +33 ;only unmapped DA PHARM locations.
- MERGE ^XTMP(PSUARSUB,"DAPH")=DAPH
- +34 QUIT
- +35 ;
- WRD() ;EP Process for ward;
- +1 NEW PSUWD,PSUWDDA,PSUDIV
- +2 SET PSUDIV=""
- +3 DO GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I")
- +4 DO MOVEMI^PSUTL("PSUWD")
- +5 ; loop ward pointers
- +6 SET PSUWDDA=0
- +7 FOR
- SET PSUWDDA=$ORDER(PSUWD(PSUWDDA))
- if PSUWDDA'>0
- QUIT
- Begin DoDot:1
- +8 SET X=$$VALI^PSUTL(42,PSUWDDA,.015)
- +9 if 'X
- QUIT
- +10 SET X=$$VALI^PSUTL(40.8,X,1)
- +11 IF $LENGTH(X)
- SET PSUDIV=X
- End DoDot:1
- if $LENGTH(PSUDIV)
- QUIT
- +12 ; return value of PSUDIV "" or = facility number
- +13 QUIT PSUDIV
- +14 ;
- INP() ;EP Process for Inpatient
- +1 ; within package call to AR/WS that pulls/builds Inpatient AOU Site
- +2 ; uses IEN Value to AOU STATs file 58.5
- +3 NEW PSUARSUB,PSUARJOB
- +4 SET PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2)
- +5 NEW PSULOC
- +6 SET PSUARSUB=PSUPRSUB
- SET PSUARJOB=PSUPRJOB
- +7 ;returns "NULL" if none found
- SET X=$$DIV^PSUAR1(PSULOCA,PSUDT)
- +8 if X="NULL"
- SET X=""
- +9 QUIT X
- +10 ;
- IV() ;EP Process,PSUIVDA for IV
- +1 ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY)
- +2 NEW PSUIV,PSUDIV
- +3 SET PSUDIV=""
- +4 DO GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I")
- +5 DO MOVEMI^PSUTL("PSUIV")
- +6 SET PSUIVDA=0
- +7 FOR
- SET PSUIVDA=$ORDER(PSUIV(PSUIVDA))
- if PSUIVDA'>0
- QUIT
- Begin DoDot:1
- +8 SET X=$$VALI^PSUTL(59.5,PSUIVDA,.02)
- +9 IF X
- SET X=$$VALI^PSUTL(40.8,X,1)
- +10 IF $LENGTH(X)
- SET PSUDIV=X
- End DoDot:1
- if $LENGTH(PSUDIV)
- QUIT
- +11 ;
- +12 QUIT PSUDIV
- +13 ;
- OUT() ;EP Process for Outpatient
- +1 SET X=$$VALI^PSUTL(58.8,PSULOC,20)
- +2 IF X
- SET X=$$VALI^PSUTL(59,X,.06)
- +3 QUIT X
- +4 ;