PSUUD1 ;BIR/TJH - PBM UNIT DOSE MODULE ;12 AUG 1999
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;DBIA(s)
; Reference to file #55 supported by DBIA 2497
; Reference to file #7 supported by DBIA 2495
; Reference to file #50 supported by DBIA 221
; Reference to file #42 supported by DBIA 2440
; Reference to file #40.8 supported by DBIA 2438
; Reference to file #200 supported by DBIA 10060
; Reference to XUA4A72 supported by DBIA 1625
;
EN ; Entry point
;
N PSUDOC1,PSUUDST
D SETUP^PSUUD2 ; set up various arrays, variables needed for processing
;
; loop thru AUD 'stop date' index
; *34 |==>
S PSDATE=PSUSDT\1-.0001 ;use 1st date of scan for 'stop date'
L1 S PSDATE=$O(^PS(55,"AUD",PSDATE))
I (PSDATE="") G STEP2
S PSPAT=0,PSUTEDT=PSUEDT\1+.2359
L2 ; loop thru patient within date
S PSPAT=$O(^PS(55,"AUD",PSDATE,PSPAT))
; <==| *34
G:PSPAT'?1.N L1
; SCREEN OUT TEST PATIENTS
G:$$TESTPAT^PSUTL1(PSPAT) L2
S PSDOSE=0
L3 ; loop thru unit dose entries within patient
S PSDOSE=$O(^PS(55,"AUD",PSDATE,PSPAT,PSDOSE))
G:PSDOSE'?1.N L2
I '$D(^PS(55,PSPAT,5,PSDOSE,11)) G L3 ;*34
S ^XTMP("PSU_"_PSUJOB,"PSUHLD",PSDOSE)=""
K PSUDOSE
S XX=$$VALI^PSUTL(55.06,"PSPAT,PSDOSE",10) ;*34
I (XX\1)>PSUTEDT G L3 ;*34
;
D GETS^PSUTL(55.06,"PSPAT,PSDOSE",".01;.5;1;9;10;26;34;68","PSUDOSE","I")
D MOVEI^PSUTL("PSUDOSE")
;.01=order number, .5=patient ptr, 1=provider ptr, 9=original ward
;10=start date/time, 26=schedule, 34=stop date/time, 68=last ward
S PSUUDST=PSUDOSE(34)\1
S PSUDOSE(10)=$P(PSUDOSE(10),".",1)
S DFN=PSUDOSE(.5) D PID^VADPT
S PSUSSN=$TR(VA("PID"),"^-","'")
I $G(PSUSSN) S ^XTMP("PSU_"_PSUJOB,"PSUTDFN",DFN,PSUSSN)=""
S PSUFACN=PSUSNDR,PSUX=$S($L(PSUDOSE(9)):PSUDOSE(9),1:PSUDOSE(68))
I $L(PSUX) D
.S PSUX1=$$VALI^PSUTL(42,PSUX,.015)
.I PSUX1'="" S PSUFACN=$$VALI^PSUTL(40.8,PSUX1,1)
PROV ; collect provider data
S (PSUVCL,PSUVS1,PSUVS2)=""
S PSUVSSN=$$VALI^PSUTL(200,PSUDOSE(1),9)
I PSUVSSN="" S PSUVSSN=999999999
S ^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN,PSUDOSE(1))=""
S PSUDOC(9)=PSUVSSN
;
S PSUVCP=$$VALI^PSUTL(200,PSUDOSE(1),53.5) ; class pointer
I PSUVCP'="" D
.S PSUVCL=$$VALI^PSUTL(7,PSUVCP,1)
.I PSUVCL="" S PSUVCL=$$VALI^PSUTL(7,PSUVCP,.01)
S PSUVSV=$$VAL^PSUTL(200,PSUDOSE(1),29) ; points to # 49,.01
S PSUVSVX=$$UPPER^PSUTL(PSUVSV),PSUVSV=""
I $L(PSUVSVX),$D(PSECT(PSUVSVX)) S PSUVSV=PSECT(PSUVSVX) ; convert to abbrev. if found in list.
S PSUSPSTR=$$GET^XUA4A72(PSUDOSE(1),PSDATE)
S PSUVS1=$P(PSUSPSTR,U,3),PSUVS2=$P(PSUSPSTR,U,4)
K PSUDAS D DISAMT^PSUUD2 ; set up dispensed amount summary array PSUDAS ;*34
D TMPUD^PSUUD2 ; store Unit Dose info in REC1
DISD ; Dispense Drug 55.06,2 Mult --> 55.07 ^PS(55,PAT,5,DOSE,1,DISP,0)
S PSUDDX=0
DISDL1 S PSUDDX=$O(^PS(55,PSPAT,5,PSDOSE,1,PSUDDX)) G:PSUDDX'?1.N DISDX
;
D GETS^PSUTL(55.07,"PSPAT,PSDOSE,PSUDDX",".01;.02;.03","PSUDISD","I")
; .01 = drug pointer, .02 = units per dose, .03 = inactive date
D MOVEI^PSUTL("PSUDISD")
I $G(PSUDISD(.01))="" G DISDL1 ; missing data, go back and try another
I $L(PSUDISD(.03)),PSUDISD(.03)<PSUSDT G DISDL1
;
;
S:PSUDISD(.02)="" PSUDISD(.02)=1 ; default to 1 if not filled per Lina B.
D GETS^PSUTL(50,PSUDISD(.01),".01;2;14.5;16;20;21;22;25;31;51;52;3","PSUDRUG","I")
I '$D(PSUDRUG) F I=.01,2,14.5,16,20,21,22,25,31,51,52,3 S PSUDRUG(I,"I")=""
D MOVEI^PSUTL("PSUDRUG")
I PSUDRUG(.01)="" S PSUDRUG(.01)="Unknown Generic Name"
I PSUDRUG(21)="" S PSUDRUG(21)="Unknown VA Product Name"
I PSUDRUG(31)="" S PSUDRUG(31)="No NDC"
I PSUDRUG(51)=1 S PSUDRUG(51)="N/F"
I PSUDRUG(52) S PSUDRUG(52)="N/F"
S PSUDNFI="",PSUDNFR="" ; National Formulary Indicator & Restriction
I $$VERSION^XPDUTL("PSN")'<4 D ; check for v.4 or greater of NDF
.S PSUDNFI=$$FORMI^PSNAPIS(PSUDRUG(20),PSUDRUG(22))
.S PSUDNFR=$$FORMR^PSNAPIS(PSUDRUG(20),PSUDRUG(22))
D TMPDD^PSUUD2 ; store dispense drug data in ^XTMP global
D LAB^PSULR0("UD",PSUFACN,PSUDOSE(.01),PSUDOSE(.5),PSUDRUG(.01),PSUDRUG(2))
G DISDL1
DISDX ; end of dispense drug, go back for next one.
G L3
;
STEP2 ; done with data collection, go back to ^PSUUD0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUUD1 4184 printed Sep 23, 2025@20:04:16 Page 2
PSUUD1 ;BIR/TJH - PBM UNIT DOSE MODULE ;12 AUG 1999
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;DBIA(s)
+3 ; Reference to file #55 supported by DBIA 2497
+4 ; Reference to file #7 supported by DBIA 2495
+5 ; Reference to file #50 supported by DBIA 221
+6 ; Reference to file #42 supported by DBIA 2440
+7 ; Reference to file #40.8 supported by DBIA 2438
+8 ; Reference to file #200 supported by DBIA 10060
+9 ; Reference to XUA4A72 supported by DBIA 1625
+10 ;
EN ; Entry point
+1 ;
+2 NEW PSUDOC1,PSUUDST
+3 ; set up various arrays, variables needed for processing
DO SETUP^PSUUD2
+4 ;
+5 ; loop thru AUD 'stop date' index
+6 ; *34 |==>
+7 ;use 1st date of scan for 'stop date'
SET PSDATE=PSUSDT\1-.0001
L1 SET PSDATE=$ORDER(^PS(55,"AUD",PSDATE))
+1 IF (PSDATE="")
GOTO STEP2
+2 SET PSPAT=0
SET PSUTEDT=PSUEDT\1+.2359
L2 ; loop thru patient within date
+1 SET PSPAT=$ORDER(^PS(55,"AUD",PSDATE,PSPAT))
+2 ; <==| *34
+3 if PSPAT'?1.N
GOTO L1
+4 ; SCREEN OUT TEST PATIENTS
+5 if $$TESTPAT^PSUTL1(PSPAT)
GOTO L2
+6 SET PSDOSE=0
L3 ; loop thru unit dose entries within patient
+1 SET PSDOSE=$ORDER(^PS(55,"AUD",PSDATE,PSPAT,PSDOSE))
+2 if PSDOSE'?1.N
GOTO L2
+3 ;*34
IF '$DATA(^PS(55,PSPAT,5,PSDOSE,11))
GOTO L3
+4 SET ^XTMP("PSU_"_PSUJOB,"PSUHLD",PSDOSE)=""
+5 KILL PSUDOSE
+6 ;*34
SET XX=$$VALI^PSUTL(55.06,"PSPAT,PSDOSE",10)
+7 ;*34
IF (XX\1)>PSUTEDT
GOTO L3
+8 ;
+9 DO GETS^PSUTL(55.06,"PSPAT,PSDOSE",".01;.5;1;9;10;26;34;68","PSUDOSE","I")
+10 DO MOVEI^PSUTL("PSUDOSE")
+11 ;.01=order number, .5=patient ptr, 1=provider ptr, 9=original ward
+12 ;10=start date/time, 26=schedule, 34=stop date/time, 68=last ward
+13 SET PSUUDST=PSUDOSE(34)\1
+14 SET PSUDOSE(10)=$PIECE(PSUDOSE(10),".",1)
+15 SET DFN=PSUDOSE(.5)
DO PID^VADPT
+16 SET PSUSSN=$TRANSLATE(VA("PID"),"^-","'")
+17 IF $GET(PSUSSN)
SET ^XTMP("PSU_"_PSUJOB,"PSUTDFN",DFN,PSUSSN)=""
+18 SET PSUFACN=PSUSNDR
SET PSUX=$SELECT($LENGTH(PSUDOSE(9)):PSUDOSE(9),1:PSUDOSE(68))
+19 IF $LENGTH(PSUX)
Begin DoDot:1
+20 SET PSUX1=$$VALI^PSUTL(42,PSUX,.015)
+21 IF PSUX1'=""
SET PSUFACN=$$VALI^PSUTL(40.8,PSUX1,1)
End DoDot:1
PROV ; collect provider data
+1 SET (PSUVCL,PSUVS1,PSUVS2)=""
+2 SET PSUVSSN=$$VALI^PSUTL(200,PSUDOSE(1),9)
+3 IF PSUVSSN=""
SET PSUVSSN=999999999
+4 SET ^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN,PSUDOSE(1))=""
+5 SET PSUDOC(9)=PSUVSSN
+6 ;
+7 ; class pointer
SET PSUVCP=$$VALI^PSUTL(200,PSUDOSE(1),53.5)
+8 IF PSUVCP'=""
Begin DoDot:1
+9 SET PSUVCL=$$VALI^PSUTL(7,PSUVCP,1)
+10 IF PSUVCL=""
SET PSUVCL=$$VALI^PSUTL(7,PSUVCP,.01)
End DoDot:1
+11 ; points to # 49,.01
SET PSUVSV=$$VAL^PSUTL(200,PSUDOSE(1),29)
+12 SET PSUVSVX=$$UPPER^PSUTL(PSUVSV)
SET PSUVSV=""
+13 ; convert to abbrev. if found in list.
IF $LENGTH(PSUVSVX)
IF $DATA(PSECT(PSUVSVX))
SET PSUVSV=PSECT(PSUVSVX)
+14 SET PSUSPSTR=$$GET^XUA4A72(PSUDOSE(1),PSDATE)
+15 SET PSUVS1=$PIECE(PSUSPSTR,U,3)
SET PSUVS2=$PIECE(PSUSPSTR,U,4)
+16 ; set up dispensed amount summary array PSUDAS ;*34
KILL PSUDAS
DO DISAMT^PSUUD2
+17 ; store Unit Dose info in REC1
DO TMPUD^PSUUD2
DISD ; Dispense Drug 55.06,2 Mult --> 55.07 ^PS(55,PAT,5,DOSE,1,DISP,0)
+1 SET PSUDDX=0
DISDL1 SET PSUDDX=$ORDER(^PS(55,PSPAT,5,PSDOSE,1,PSUDDX))
if PSUDDX'?1.N
GOTO DISDX
+1 ;
+2 DO GETS^PSUTL(55.07,"PSPAT,PSDOSE,PSUDDX",".01;.02;.03","PSUDISD","I")
+3 ; .01 = drug pointer, .02 = units per dose, .03 = inactive date
+4 DO MOVEI^PSUTL("PSUDISD")
+5 ; missing data, go back and try another
IF $GET(PSUDISD(.01))=""
GOTO DISDL1
+6 IF $LENGTH(PSUDISD(.03))
IF PSUDISD(.03)<PSUSDT
GOTO DISDL1
+7 ;
+8 ;
+9 ; default to 1 if not filled per Lina B.
if PSUDISD(.02)=""
SET PSUDISD(.02)=1
+10 DO GETS^PSUTL(50,PSUDISD(.01),".01;2;14.5;16;20;21;22;25;31;51;52;3","PSUDRUG","I")
+11 IF '$DATA(PSUDRUG)
FOR I=.01,2,14.5,16,20,21,22,25,31,51,52,3
SET PSUDRUG(I,"I")=""
+12 DO MOVEI^PSUTL("PSUDRUG")
+13 IF PSUDRUG(.01)=""
SET PSUDRUG(.01)="Unknown Generic Name"
+14 IF PSUDRUG(21)=""
SET PSUDRUG(21)="Unknown VA Product Name"
+15 IF PSUDRUG(31)=""
SET PSUDRUG(31)="No NDC"
+16 IF PSUDRUG(51)=1
SET PSUDRUG(51)="N/F"
+17 IF PSUDRUG(52)
SET PSUDRUG(52)="N/F"
+18 ; National Formulary Indicator & Restriction
SET PSUDNFI=""
SET PSUDNFR=""
+19 ; check for v.4 or greater of NDF
IF $$VERSION^XPDUTL("PSN")'<4
Begin DoDot:1
+20 SET PSUDNFI=$$FORMI^PSNAPIS(PSUDRUG(20),PSUDRUG(22))
+21 SET PSUDNFR=$$FORMR^PSNAPIS(PSUDRUG(20),PSUDRUG(22))
End DoDot:1
+22 ; store dispense drug data in ^XTMP global
DO TMPDD^PSUUD2
+23 DO LAB^PSULR0("UD",PSUFACN,PSUDOSE(.01),PSUDOSE(.5),PSUDRUG(.01),PSUDRUG(2))
+24 GOTO DISDL1
DISDX ; end of dispense drug, go back for next one.
+1 GOTO L3
+2 ;
STEP2 ; done with data collection, go back to ^PSUUD0
+1 QUIT
