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

PSUPR2.m

Go to the documentation of this file.
  1. 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
  1. ;DBIAs
  1. ; Reference to file #58.811 supported by DBIA 2521
  1. ; Reference to file #51.5 supported by DBIA 1931
  1. ; Reference to file #50 supported by DBIA 221
  1. ; Reference to file #58.8 supported by DBIA 2519
  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. ; Reference to file #59 supported by DBIA 2510
  1. ;
  1. EN ;
  1. S PSUEND=PSUEDT
  1. S PSUEDT=PSUEDT\1+.24
  1. S:'$D(PSUPRJOB) PSUPRJOB=$J
  1. S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J
  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. ;
  1. S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
  1. D MAP
  1. ;
  1. ; check for Drug Accountability
  1. S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY")
  1. I 'X Q ; not installed
  1. ;
  1. S X1=PSUSDT,X2=-45 ;backup by 45 days per revision
  1. D C^%DTC
  1. S PSUDT=X
  1. ; loop thru invoice date field xref
  1. F S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT Q:PSUDT'>0 D
  1. . S PSUORDA=0 F S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0 D
  1. .. S PSUINVDA=0 F S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0 D INVOICE
  1. Q
  1. ;
  1. INVOICE ;EP process an invoice within an order
  1. N PSUSTAT
  1. S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2)
  1. I PSUSTAT'="C" Q ; 3.2.6.1
  1. N PSUORD
  1. D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD")
  1. ;
  1. S PSUINV=""
  1. N PSURDT,PSUIVNUM
  1. D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I")
  1. D MOVEI^PSUTL("PSUINV")
  1. S PSURDT=PSUINV(8)
  1. S PSUIVNUM=PSUINV(.01)
  1. ;
  1. ;*18 Clear out Division for each invoice.
  1. S PSUDIV=""
  1. I $G(PSUINV(4)) D DIV
  1. I $L(PSUDIV) S PSUDIVI=""
  1. E S PSUDIV=PSUSNDR,PSUDIVI="H"
  1. ;
  1. ;
  1. K ^TMP($J,"PSUMIT") ; array for multiple items
  1. D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I")
  1. I '$D(^TMP($J,"PSUMIT")) Q ;
  1. D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
  1. ;
  1. S PSUITDA=0 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM
  1. Q
  1. ITEM ;EP process one item within the invoice
  1. N PSUIT ; array for one item
  1. M PSUIT=^TMP($J,"PSUMIT",PSUITDA)
  1. ;
  1. I (PSUIT(7)<PSUSDT) Q
  1. I (PSUIT(7)>PSUEDT) Q
  1. ; pull adjustments 3.2.6.2.8
  1. N PSUMADJ
  1. D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I")
  1. I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ")
  1. ;
  1. ;
  1. ; Review/Process Adjustments
  1. I $D(PSUMADJ) S PSUADJDA=0 F S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0 D
  1. . N PSUADJ
  1. . M PSUADJ=PSUMADJ(PSUADJDA)
  1. . ;
  1. . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5) ; 3.2.6.2.8 Drug or Supply
  1. . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5) ; 3.2.6.2.11 OrderUnits
  1. . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5) ; 3.2.6.2.12 Price
  1. . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity
  1. . Q
  1. ;
  1. I 'PSUIT(2) Q ; per Lina 10/7/98 if qty = 0 don't send record
  1. ; work on the order unit PSUIT(3)
  1. I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina
  1. I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11
  1. ;
  1. ; further process item fields 3.2.6.2.9 +
  1. ;
  1. ; look for/ construct Dispense Units per Order Unit
  1. ; Store in PSUIT(9999) 3.2.6.2.13
  1. ; Get Related Drug Fields 3.2.6.2.9
  1. ;
  1. N PSUDRUG
  1. S PSUDRDA=0
  1. ; if PSUIT(1) is a supply item the following will not be computed
  1. I PSUIT(1)=+PSUIT(1) D
  1. . S PSUDRDA=PSUIT(1)
  1. . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
  1. . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I")
  1. . D MOVEI^PSUTL("PSUDRUG")
  1. . S PSUIT(1)=PSUDRUG(.01) ; Generic Name
  1. . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name"
  1. . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC"
  1. ; further process fields
  1. ; fill in drug fields for supply items
  1. I 'PSUDRDA D
  1. . S PSUDRUG(.01)="Unknown Generic Name"
  1. . S PSUDRUG(21)="Unknown VA Product Name"
  1. . S PSUDRUG(31)="No NDC"
  1. ;
  1. ; NDC
  1. I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC"
  1. ;
  1. ; dispense units per order unit 3.2.6.2.13
  1. ;
  1. S PSUIT(9999)=0
  1. I $L(PSUIT(13)),$G(PSUDRDA) D
  1. . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,""))
  1. . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403")
  1. ;
  1. I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina
  1. ;
  1. ;PSU*4*13 Comment out To prevent XINDEX from complaining about
  1. ; ^PSUPR7 (CoreFLS remnance)
  1. ;Create "RECORDS" global for CoreFLS data
  1. ;I $D(PSUFLSFG) S PSUA="" D
  1. ;.F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7
  1. ;
  1. ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC)
  1. S PSUR=$$RECORD()
  1. ; Store Records by Division
  1. S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
  1. S PSULC=PSULC+1
  1. S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR
  1. Q
  1. ;
  1. RECORD() ;EP Assemble record
  1. N PSUR
  1. S PSUR(2)=$G(PSUDIV)
  1. S PSUR(3)=$G(PSUDIVI)
  1. S PSUR(4)=PSUIT(7)\1 ; 3.2.6.2.2
  1. S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9
  1. S PSUR(6)=$G(PSUDRUG(2)) ; ""
  1. S PSUR(7)=PSUIT(1) ; 3.2.6.2.8
  1. S PSUR(9)=PSUIT(13) ; 3.2.6.2.9
  1. S PSUR(10)=PSUIT(14) ; ""
  1. S PSUR(11)=PSUIT(15) ; ""
  1. S PSUR(12)=$G(PSUDRUG(14.5)) ; ""
  1. S PSUR(13)=PSUIT(3) ; 3.2.6.2.11
  1. S PSUR(16)=PSUIT(9999) ; 3.2.6.2.13
  1. S PSUR(17)=PSUIT(2) ; 3.2.6.2.10
  1. S PSUR(18)=PSUIT(4) ; 3.2.6.2.12
  1. S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14
  1. S PSUR(20)=PSUORD(1) ; 3.2.6.2.5
  1. S PSUR(21)=PSUINV(.01) ; 3.2.6.2.6
  1. S PSUR(22)=""
  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,U,I)=PSUR(I)
  1. S PSUR=PSUR_U
  1. Q PSUR
  1. ;
  1. DIV ;Find division or outpatient site
  1. ;
  1. S PSUDIV=""
  1. N MAPLOCI
  1. D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I")
  1. D MOVEMI^PSUTL("MAPLOCI")
  1. ;
  1. I $G(MAPLOCI(PSUINV(4),.01)) D
  1. .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
  1. .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
  1. I '$G(MAPLOCI(PSUINV(4),.01)) D
  1. .S PSUDIV=PSUSNDR
  1. .S PSUDIVI="H"
  1. Q
  1. ;
  1. ;
  1. 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
  1. ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a
  1. ;global to be mailed to the user.
  1. ;
  1. K NAOU,DAPH
  1. K MAPLOCI,MAPLOC
  1. S PSUNAM=0 ;This is the name of the NAOU or DA PHARMACY
  1. ;
  1. F S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM="" D
  1. .S IEN=0
  1. .F S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN="" D
  1. ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)")
  1. ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN)
  1. ..D MAP1
  1. ;
  1. Q
  1. ;
  1. 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.
  1. ;
  1. ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is
  1. ;no value in subfield .02 or .03, then an NAOU has not been mapped.
  1. ;
  1. ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is
  1. ;no value in subfield .02 or .03, then a DA PHARMACY location has not
  1. ;been mapped.
  1. ;
  1. ;Keep only the entries that are NOT mapped
  1. ;
  1. N PSUDA
  1. ;
  1. ;Look for unmapped NAOU's
  1. ;I $G(NAOU(IEN),1) D
  1. I $G(^PS(59.7,1,90.02,IEN,0)) D
  1. .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI")
  1. .S PSUDA=0
  1. .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D
  1. ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA)
  1. ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA)
  1. M ^XTMP(PSUARSUB,"NAOU")=NAOU ;only unmapped NAOU locations.
  1. ;
  1. ;
  1. ;Look for unmapped DA PHARM
  1. I $G(^PS(59.7,1,90.03,IEN,0)) D
  1. .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC")
  1. .S PSUDA=0
  1. .F S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA="" D
  1. ..;PSU*4*13 Correct Problm DA Pharm Report
  1. ..I $G(MAPLOC(PSUDA,.02))'="" K DAPH(PSUDA)
  1. ..I $G(MAPLOC(PSUDA,.03))'="" K DAPH(PSUDA)
  1. M ^XTMP(PSUARSUB,"DAPH")=DAPH ;only unmapped DA PHARM locations.
  1. Q
  1. ;
  1. WRD() ;EP Process for ward;
  1. N PSUWD,PSUWDDA,PSUDIV
  1. S PSUDIV=""
  1. D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I")
  1. D MOVEMI^PSUTL("PSUWD")
  1. ; loop ward pointers
  1. S PSUWDDA=0
  1. F S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0 D Q:$L(PSUDIV)
  1. . S X=$$VALI^PSUTL(42,PSUWDDA,.015)
  1. . Q:'X
  1. . S X=$$VALI^PSUTL(40.8,X,1)
  1. . I $L(X) S PSUDIV=X
  1. ; return value of PSUDIV "" or = facility number
  1. Q PSUDIV
  1. ;
  1. INP() ;EP Process for Inpatient
  1. ; within package call to AR/WS that pulls/builds Inpatient AOU Site
  1. ; uses IEN Value to AOU STATs file 58.5
  1. N PSUARSUB,PSUARJOB
  1. S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2)
  1. N PSULOC
  1. S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB
  1. S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found
  1. S:X="NULL" X=""
  1. Q X
  1. ;
  1. IV() ;EP Process,PSUIVDA for IV
  1. ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY)
  1. N PSUIV,PSUDIV
  1. S PSUDIV=""
  1. D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I")
  1. D MOVEMI^PSUTL("PSUIV")
  1. S PSUIVDA=0
  1. F S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0 D Q:$L(PSUDIV)
  1. . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02)
  1. . I X S X=$$VALI^PSUTL(40.8,X,1)
  1. . I $L(X) S PSUDIV=X
  1. ;
  1. Q PSUDIV
  1. ;
  1. OUT() ;EP Process for Outpatient
  1. S X=$$VALI^PSUTL(58.8,PSULOC,20)
  1. I X S X=$$VALI^PSUTL(59,X,.06)
  1. Q X
  1. ;