PSUAR1 ;BIR/PDW - Start AR/WS Extract ;11 AUG 1999
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;;
;PSUDTDA - IEN FOR DATE
;PSUSDA - IEN FOR INPATIENT SITE
;PSUDRDA - IEN FOR DRUG
;PSUCDA - IEN FOR CATEGORY
;PSUDIV - IEN FOR DIVISION OR "NONE"
;
;DBIAs
; Reference to file #58.5 supported by DBIA 456
; Reference to file #58.1 supported by DBIA 2515
; Reference to file #59.4 supported by DBIA 2498
; Reference to file #44 supported by DBIA 2439
; Reference to file #40.8 supported by DBIA 2438
; Reference to file #59 supported by DBIA 1876
; Reference to file #59.7 supported by DBIA 2854
;
EN ;EP MAIN ENTRY POINT
;
K PSUTDSP,PSUTRET
;
START ;Start date scan thru stats file
S PSUSDT=PSUSDT-.1
S PSUDT=PSUSDT
S PSUEDT=PSUEDT\1+.24
Q F S PSUDT=$O(^PSI(58.5,"B",PSUDT)) Q:'PSUDT Q:PSUDT>PSUEDT D DATE Q:$G(PSUQUIT)
Q
DATE ;PROCESS ONE DATE - Loop through inpatient sites
S PSUDTDA=$O(^PSI(58.5,"B",PSUDT,0))
K PSUSITE
D GETM^PSUTL(58.5,PSUDTDA,"1*^.01","PSUSITE")
S PSUSDA=0
F S PSUSDA=$O(PSUSITE(PSUSDA)) Q:PSUSDA'>0 D SITE Q:$G(PSUQUIT)
K PSUSITE
Q
;
SITE ;Process one site for one date
; Find division for site for loading drug stats
S PSUDIV=$$DIV(PSUSDA,PSUDTDA)
;
I PSUDIV="NULL" S PSUDIV=PSUSNDR
;
; Process individual Drug information from 58.52
; Drug multiple loaded into PSUDRUG
K PSUDRUG
D GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","2*^.01","PSUDRUG")
S PSUDRDA=0
F S PSUDRDA=$O(PSUDRUG(PSUDRDA)) Q:PSUDRDA'>0 D DRUG Q:$G(PSUQUIT)
K PSUDRUG
;
D MAP
; Process Amis categories from 58.501
; Category multiple loaded into PSUCAT
K PSUCAT
CATEGORY ;EP Pull Categories
K PSUAMCAT
D GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","1*^.01;1;2;3;4","PSUAMCAT","I")
;
; Move (da,Fld,"I") values to (da,Fld) nodes
D MOVEMI^PSUTL("PSUAMCAT")
;
; Gather totals for categories and accumulate in
; ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP":COST")
N PSUDISP,PSUCOST
S PSUCDA=0 F S PSUCDA=$O(PSUAMCAT(PSUCDA)) Q:PSUCDA'>0 D
. S PSUDISP=PSUAMCAT(PSUCDA,1)-PSUAMCAT(PSUCDA,3)
. S PSUCOST=PSUAMCAT(PSUCDA,2)-PSUAMCAT(PSUCDA,4)
. S PSUAMCAT=PSUAMCAT(PSUCDA,.01) ; "03"-"04"-"06" etc
. S X=$G(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP"))
. S ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP")=X+PSUDISP
. S X=$G(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST"))
. S ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")=X+PSUCOST
. M ^XTMP("PSUTCST",PSUDIV,PSUAMCAT)=^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")
;
Q
;
DRUG ; Process one drug for one site for one day
; Load & loop categories within Drug
; total dispense & returns
; Category multiple loaded into PSUCAT
;
S PSUDRIEN=$$VALI^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA",.01)
K PSUCAT
D GETM^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA","1*^.01;1","PSUCAT","I")
;
S PSUCDA=0,PSUDISP=0,PSUTR=0
F S PSUCDA=$O(PSUCAT(PSUCDA)) Q:PSUCDA'>0 Q:$G(PSUQUIT) D
. S X=PSUCAT(PSUCDA,.01,"I")
. S Y=PSUCAT(PSUCDA,1,"I")
. I (X="A")!(X="W") S PSUDISP=PSUDISP+Y,PSUTDS=PSUDISP
. I (X="RA")!(X="RW") S PSUDISP=PSUDISP-Y,PSUTR=PSUTR+Y
; Adjust accumulative dispenses
;
S X=$G(^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN))
S ^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN)=X+PSUDISP
;
N PSUT
S PSUT=$G(PSUTDSP(PSUDIV,PSUDRIEN))
I $D(PSUTDS) D
.S PSUTDSP(PSUDIV,PSUDRIEN)=PSUTDS+PSUT ;Total Quantity dispensed
.I (PSUTDS+PSUT)=0 S PSUTDSP(PSUDIV,PSUDRIEN)=""
;
N PSUT1
S PSUT1=$G(PSUTRET(PSUDIV,PSUDRIEN))
I $D(PSUTR) D
.S PSUTRET(PSUDIV,PSUDRIEN)=PSUTR+PSUT1 ;Total Quantity returned
.I (PSUTR+PSUT1)=0 S PSUTRET(PSUDIV,PSUDRIEN)=""
K PSUCAT
Q
DIV(PSUSDA,PSUDTDA) ;EP process for a site the associated divisions by date.
; uses PSUSDA as entry for site ien in file 59.4 : returns division
; as of 2/99 date is no longer used as a parameter
N PSUDIV,PSUDT
I '$D(^XTMP(PSUARSUB,"DIVLK",PSUSDA)) D AOU
; ^XTMP(PSUARSUB,"DIVlk",Site IEN, AOU Inactive Date -1)=Division IEN
;
; if AOU did not set division then return null
I '$D(^XTMP(PSUARSUB,"DIVLK",PSUSDA)) S PSUDIV="NULL" Q PSUDIV
;
S PSUDIV=$O(^XTMP(PSUARSUB,"DIVLK",PSUSDA,""))
Q PSUDIV
;
AOU ;EP map divisions by dates for inpatient sites from the AOU file
;PSUADA - ien for AOU Stock file
;
N PSUADA,PSUDIV,PSUINACT,PSUDIV,PSUSLOC,MAPLOCI
;
D GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI","I")
;set array MAPLOCI(ien,fld)=internal value
;field .02 points to 40.8 Medical Center Division where fac num is #1
;field .03 points to 59 Outpatient site where site num is #.06
D MOVEMI^PSUTL("MAPLOCI")
;
K ^XTMP(PSUARSUB,"DIVLK")
;
S PSUADA=0
F S PSUADA=$O(^PSI(58.1,"ASITE",PSUSDA,PSUADA)) Q:PSUADA'>0 D
. N PSUDIV S PSUDIV=""
. S PSUSLOC=$$VALI^PSUTL(59.4,PSUSDA,.01)
. S PSUINACT=$$VALI^PSUTL(58.1,PSUADA,3)
. I PSUINACT Q ; inactivated sites are to be ignored regardles of date
. S:'PSUINACT PSUINACT=DT+1
. I '$G(MAPLOCI(PSUADA,.01)) S PSUDIV="NULL"
. I $G(MAPLOCI(PSUADA,.01)) D
.. S X=$G(MAPLOCI(PSUADA,.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
.. S X=$G(MAPLOCI(PSUADA,.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
.. S ^XTMP(PSUARSUB,"DIVLK",PSUSDA,PSUDIV)=""
;
Q
;
MAP ;Find out whether an Area of Use (AOU) is mapped to a division or
;outpatient site. If it is not mapped, store the NAME and INACTIVATION
;DATE (if applicable) in a global to be mailed to the user.
;
S PSUNAM=0 ;This is the name of the Area of USE
;
F S PSUNAM=$O(^PSI(58.1,"B",PSUNAM)) Q:PSUNAM="" D
.S IEN=0 ;This is the IEN for file 58.1
.F S IEN=$O(^PSI(58.1,"B",PSUNAM,IEN)) Q:IEN="" D
..K AOU
..D GETS^PSUTL(58.1,IEN,".01;3","AOU(IEN)") ;Name & Inactive Date
..D MAP1
Q
;
MAP1 ;MAP continued. This subroutine takes the IEN from file 58.1 and looks
;to see if it is in file 59.7, field 90.01. If it is, then it has
;been mapped if there is a value in subfield .02 or .03.
;If there is no value in subfield .02 or .03 it has not been mapped
;
;Keep only the entries that are NOT mapped
;
N PSUDA
;
I $G(^PS(59.7,1,90.01,IEN,0)) D
.D GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI")
.S PSUDA=0
.F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D
..I MAPLOCI(PSUDA,.02)'="" K AOU(PSUDA)
..I $G(MAPLOCI(PSUDA,.03))'="" K AOU(PSUDA)
M ^XTMP(PSUARSUB,"AOU")=AOU ;Contains only unmapped locations
Q
;
CLEAR ;EP Clear ^XTMP("PSUAR*")
S X="PSUAR",Y=X
F S Y=$O(^XTMP(Y)) Q:($E(Y,1,5)'=X) W !,Y K ^XTMP(Y)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUAR1 6612 printed Sep 23, 2025@20:03 Page 2
PSUAR1 ;BIR/PDW - Start AR/WS Extract ;11 AUG 1999
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;;
+3 ;PSUDTDA - IEN FOR DATE
+4 ;PSUSDA - IEN FOR INPATIENT SITE
+5 ;PSUDRDA - IEN FOR DRUG
+6 ;PSUCDA - IEN FOR CATEGORY
+7 ;PSUDIV - IEN FOR DIVISION OR "NONE"
+8 ;
+9 ;DBIAs
+10 ; Reference to file #58.5 supported by DBIA 456
+11 ; Reference to file #58.1 supported by DBIA 2515
+12 ; Reference to file #59.4 supported by DBIA 2498
+13 ; Reference to file #44 supported by DBIA 2439
+14 ; Reference to file #40.8 supported by DBIA 2438
+15 ; Reference to file #59 supported by DBIA 1876
+16 ; Reference to file #59.7 supported by DBIA 2854
+17 ;
EN ;EP MAIN ENTRY POINT
+1 ;
+2 KILL PSUTDSP,PSUTRET
+3 ;
START ;Start date scan thru stats file
+1 SET PSUSDT=PSUSDT-.1
+2 SET PSUDT=PSUSDT
+3 SET PSUEDT=PSUEDT\1+.24
Q FOR
SET PSUDT=$ORDER(^PSI(58.5,"B",PSUDT))
if 'PSUDT
QUIT
if PSUDT>PSUEDT
QUIT
DO DATE
if $GET(PSUQUIT)
QUIT
+1 QUIT
DATE ;PROCESS ONE DATE - Loop through inpatient sites
+1 SET PSUDTDA=$ORDER(^PSI(58.5,"B",PSUDT,0))
+2 KILL PSUSITE
+3 DO GETM^PSUTL(58.5,PSUDTDA,"1*^.01","PSUSITE")
+4 SET PSUSDA=0
+5 FOR
SET PSUSDA=$ORDER(PSUSITE(PSUSDA))
if PSUSDA'>0
QUIT
DO SITE
if $GET(PSUQUIT)
QUIT
+6 KILL PSUSITE
+7 QUIT
+8 ;
SITE ;Process one site for one date
+1 ; Find division for site for loading drug stats
+2 SET PSUDIV=$$DIV(PSUSDA,PSUDTDA)
+3 ;
+4 IF PSUDIV="NULL"
SET PSUDIV=PSUSNDR
+5 ;
+6 ; Process individual Drug information from 58.52
+7 ; Drug multiple loaded into PSUDRUG
+8 KILL PSUDRUG
+9 DO GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","2*^.01","PSUDRUG")
+10 SET PSUDRDA=0
+11 FOR
SET PSUDRDA=$ORDER(PSUDRUG(PSUDRDA))
if PSUDRDA'>0
QUIT
DO DRUG
if $GET(PSUQUIT)
QUIT
+12 KILL PSUDRUG
+13 ;
+14 DO MAP
+15 ; Process Amis categories from 58.501
+16 ; Category multiple loaded into PSUCAT
+17 KILL PSUCAT
CATEGORY ;EP Pull Categories
+1 KILL PSUAMCAT
+2 DO GETM^PSUTL(58.501,"PSUDTDA,PSUSDA","1*^.01;1;2;3;4","PSUAMCAT","I")
+3 ;
+4 ; Move (da,Fld,"I") values to (da,Fld) nodes
+5 DO MOVEMI^PSUTL("PSUAMCAT")
+6 ;
+7 ; Gather totals for categories and accumulate in
+8 ; ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP":COST")
+9 NEW PSUDISP,PSUCOST
+10 SET PSUCDA=0
FOR
SET PSUCDA=$ORDER(PSUAMCAT(PSUCDA))
if PSUCDA'>0
QUIT
Begin DoDot:1
+11 SET PSUDISP=PSUAMCAT(PSUCDA,1)-PSUAMCAT(PSUCDA,3)
+12 SET PSUCOST=PSUAMCAT(PSUCDA,2)-PSUAMCAT(PSUCDA,4)
+13 ; "03"-"04"-"06" etc
SET PSUAMCAT=PSUAMCAT(PSUCDA,.01)
+14 SET X=$GET(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP"))
+15 SET ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"DISP")=X+PSUDISP
+16 SET X=$GET(^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST"))
+17 SET ^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")=X+PSUCOST
+18 MERGE ^XTMP("PSUTCST",PSUDIV,PSUAMCAT)=^XTMP(PSUARSUB,"DIV_CAT",PSUDIV,PSUAMCAT,"COST")
End DoDot:1
+19 ;
+20 QUIT
+21 ;
DRUG ; Process one drug for one site for one day
+1 ; Load & loop categories within Drug
+2 ; total dispense & returns
+3 ; Category multiple loaded into PSUCAT
+4 ;
+5 SET PSUDRIEN=$$VALI^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA",.01)
+6 KILL PSUCAT
+7 DO GETM^PSUTL(58.52,"PSUDTDA,PSUSDA,PSUDRDA","1*^.01;1","PSUCAT","I")
+8 ;
+9 SET PSUCDA=0
SET PSUDISP=0
SET PSUTR=0
+10 FOR
SET PSUCDA=$ORDER(PSUCAT(PSUCDA))
if PSUCDA'>0
QUIT
if $GET(PSUQUIT)
QUIT
Begin DoDot:1
+11 SET X=PSUCAT(PSUCDA,.01,"I")
+12 SET Y=PSUCAT(PSUCDA,1,"I")
+13 IF (X="A")!(X="W")
SET PSUDISP=PSUDISP+Y
SET PSUTDS=PSUDISP
+14 IF (X="RA")!(X="RW")
SET PSUDISP=PSUDISP-Y
SET PSUTR=PSUTR+Y
End DoDot:1
+15 ; Adjust accumulative dispenses
+16 ;
+17 SET X=$GET(^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN))
+18 SET ^XTMP(PSUARSUB,"DIV_DRUG",PSUDIV,PSUDRIEN)=X+PSUDISP
+19 ;
+20 NEW PSUT
+21 SET PSUT=$GET(PSUTDSP(PSUDIV,PSUDRIEN))
+22 IF $DATA(PSUTDS)
Begin DoDot:1
+23 ;Total Quantity dispensed
SET PSUTDSP(PSUDIV,PSUDRIEN)=PSUTDS+PSUT
+24 IF (PSUTDS+PSUT)=0
SET PSUTDSP(PSUDIV,PSUDRIEN)=""
End DoDot:1
+25 ;
+26 NEW PSUT1
+27 SET PSUT1=$GET(PSUTRET(PSUDIV,PSUDRIEN))
+28 IF $DATA(PSUTR)
Begin DoDot:1
+29 ;Total Quantity returned
SET PSUTRET(PSUDIV,PSUDRIEN)=PSUTR+PSUT1
+30 IF (PSUTR+PSUT1)=0
SET PSUTRET(PSUDIV,PSUDRIEN)=""
End DoDot:1
+31 KILL PSUCAT
+32 QUIT
DIV(PSUSDA,PSUDTDA) ;EP process for a site the associated divisions by date.
+1 ; uses PSUSDA as entry for site ien in file 59.4 : returns division
+2 ; as of 2/99 date is no longer used as a parameter
+3 NEW PSUDIV,PSUDT
+4 IF '$DATA(^XTMP(PSUARSUB,"DIVLK",PSUSDA))
DO AOU
+5 ; ^XTMP(PSUARSUB,"DIVlk",Site IEN, AOU Inactive Date -1)=Division IEN
+6 ;
+7 ; if AOU did not set division then return null
+8 IF '$DATA(^XTMP(PSUARSUB,"DIVLK",PSUSDA))
SET PSUDIV="NULL"
QUIT PSUDIV
+9 ;
+10 SET PSUDIV=$ORDER(^XTMP(PSUARSUB,"DIVLK",PSUSDA,""))
+11 QUIT PSUDIV
+12 ;
AOU ;EP map divisions by dates for inpatient sites from the AOU file
+1 ;PSUADA - ien for AOU Stock file
+2 ;
+3 NEW PSUADA,PSUDIV,PSUINACT,PSUDIV,PSUSLOC,MAPLOCI
+4 ;
+5 DO GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI","I")
+6 ;set array MAPLOCI(ien,fld)=internal value
+7 ;field .02 points to 40.8 Medical Center Division where fac num is #1
+8 ;field .03 points to 59 Outpatient site where site num is #.06
+9 DO MOVEMI^PSUTL("MAPLOCI")
+10 ;
+11 KILL ^XTMP(PSUARSUB,"DIVLK")
+12 ;
+13 SET PSUADA=0
+14 FOR
SET PSUADA=$ORDER(^PSI(58.1,"ASITE",PSUSDA,PSUADA))
if PSUADA'>0
QUIT
Begin DoDot:1
+15 NEW PSUDIV
SET PSUDIV=""
+16 SET PSUSLOC=$$VALI^PSUTL(59.4,PSUSDA,.01)
+17 SET PSUINACT=$$VALI^PSUTL(58.1,PSUADA,3)
+18 ; inactivated sites are to be ignored regardles of date
IF PSUINACT
QUIT
+19 if 'PSUINACT
SET PSUINACT=DT+1
+20 IF '$GET(MAPLOCI(PSUADA,.01))
SET PSUDIV="NULL"
+21 IF $GET(MAPLOCI(PSUADA,.01))
Begin DoDot:2
+22 SET X=$GET(MAPLOCI(PSUADA,.02))
IF X
SET PSUDIV=$$VALI^PSUTL(40.8,X,1)
+23 SET X=$GET(MAPLOCI(PSUADA,.03))
IF X
SET PSUDIV=$$VALI^PSUTL(59,X,.06)
+24 SET ^XTMP(PSUARSUB,"DIVLK",PSUSDA,PSUDIV)=""
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
+27 ;
MAP ;Find out whether an Area of Use (AOU) is mapped to a division or
+1 ;outpatient site. If it is not mapped, store the NAME and INACTIVATION
+2 ;DATE (if applicable) in a global to be mailed to the user.
+3 ;
+4 ;This is the name of the Area of USE
SET PSUNAM=0
+5 ;
+6 FOR
SET PSUNAM=$ORDER(^PSI(58.1,"B",PSUNAM))
if PSUNAM=""
QUIT
Begin DoDot:1
+7 ;This is the IEN for file 58.1
SET IEN=0
+8 FOR
SET IEN=$ORDER(^PSI(58.1,"B",PSUNAM,IEN))
if IEN=""
QUIT
Begin DoDot:2
+9 KILL AOU
+10 ;Name & Inactive Date
DO GETS^PSUTL(58.1,IEN,".01;3","AOU(IEN)")
+11 DO MAP1
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
MAP1 ;MAP continued. This subroutine takes the IEN from file 58.1 and looks
+1 ;to see if it is in file 59.7, field 90.01. If it is, then it has
+2 ;been mapped if there is a value in subfield .02 or .03.
+3 ;If there is no value in subfield .02 or .03 it has not been mapped
+4 ;
+5 ;Keep only the entries that are NOT mapped
+6 ;
+7 NEW PSUDA
+8 ;
+9 IF $GET(^PS(59.7,1,90.01,IEN,0))
Begin DoDot:1
+10 DO GETM^PSUTL(59.7,1,"90.01*^.01;.02;.03","MAPLOCI")
+11 SET PSUDA=0
+12 FOR
SET PSUDA=$ORDER(MAPLOCI(PSUDA))
if PSUDA=""
QUIT
Begin DoDot:2
+13 IF MAPLOCI(PSUDA,.02)'=""
KILL AOU(PSUDA)
+14 IF $GET(MAPLOCI(PSUDA,.03))'=""
KILL AOU(PSUDA)
End DoDot:2
End DoDot:1
+15 ;Contains only unmapped locations
MERGE ^XTMP(PSUARSUB,"AOU")=AOU
+16 QUIT
+17 ;
CLEAR ;EP Clear ^XTMP("PSUAR*")
+1 SET X="PSUAR"
SET Y=X
+2 FOR
SET Y=$ORDER(^XTMP(Y))
if ($EXTRACT(Y,1,5)'=X)
QUIT
WRITE !,Y
KILL ^XTMP(Y)
+3 QUIT
