PSUOP1 ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 6.0 ;25 AUG 1998
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;DBIAs
; Reference to ^PSRX( file #52 supported by DBIA(s) 465, 2512, 2513
EN ;Entry to data collection
K ^TMP($J)
D CMOPARY,ADLOOP
Q
ADLOOP ;Loop through the AD cross reference
S X1=PSUSDT,X2=-31
D C^%DTC K %,%H,%T
S PSUFDT=X
F S PSUFDT=$O(^PSRX("AD",PSUFDT)) Q:PSUFDT=""!(PSUFDT\1>PSUEDT) D
.S PSURXIEN=""
.F S PSURXIEN=$O(^PSRX("AD",PSUFDT,PSURXIEN)) Q:PSURXIEN="" D
..S PSUFIL=""
..F S PSUFIL=$O(^PSRX("AD",PSUFDT,PSURXIEN,PSUFIL)) Q:PSUFIL="" D
...Q:'$D(^PSRX(PSURXIEN,0))
...K PSUTYP,PSUOP
...S PSUFLN=PSUFIL
...D COMVAR
...S PSUCMOP="N"
...;
...; check for CMOP data
...I $D(^PSRX(PSURXIEN,4,0)) D ARLOOP
...I PSUCMOP="Y" Q ; record filed in subroutine
...I (PSUFDT\1<PSUSDT) Q
...S PSUTYP=$S(PSUFLN=0:"N",1:"R")
...D GETDATA
...D SETREC^PSUOP3
..I $D(^PSRX(PSURXIEN,"P",0)),'$D(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)) D ADPLOOP
K ^TMP($J)
Q
ARLOOP ;Check to see if CMOP Data exists for the reporting period
I $D(^TMP($J,PSURXIEN,PSUFLN)) D
.S PSUCMOP="Y"
.S PSUTYP=$S(PSUFLN=0:"N",1:"R")
.D GETDATA
.I (PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDT) Q
.D SETREC^PSUOP3
Q
ADPLOOP ;Get data for partial fills
S PSUPFN=0
F S PSUPFN=$O(^PSRX(PSURXIEN,"P",PSUPFN)) Q:'PSUPFN D
.S PSUCMOP="N"
.D COMVAR
.S PSUTYP="P"
.D GETPART
.Q:((PSUFD<PSUSDT)!(PSUFD>PSUEDT))
.D SETREC^PSUOP3
Q
GETDATA ;Get the data for New Fills, Refills and Partial fills
I PSUTYP="N" D
.S PSUFD=PSUOP(22)
.S PSUDS=PSUOP(8)
.S PSUQTY=+PSUOP(7)
.S PSUDRCT=PSUOP(17)
.S PSURELDT=PSUOP(31)
.I PSURELDT'="" S PSURELDT=PSURELDT\1
.S PSUPRID=PSUOP(4)
.S PSUMW=PSUOP(11)
.S PSUDIVP=PSUOP(20)
.S PSUNDC=""
.I PSUCMOP="Y" D
..S PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)
.S PSUNDC=$S(PSUNDC="":PSUOP(27),PSUNDC="":PSUDRUG(31),1:"No NDC")
.D PROVDR^PSUOP3
;Get data for Refills
I PSUTYP="R" D K REC
.D GETS^PSUTL(52.1,"PSURXIEN,PSUFLN",".01;1;1.1;1.2;2;8;15;17","PSUREFIL","I")
.D MOVEI^PSUTL("PSUREFIL")
.S PSUFD=PSUREFIL(.01)
.S PSUPRID=PSUREFIL(15)
.S PSUMW=PSUREFIL(2)
.S PSUDIVP=PSUREFIL(8)
.S PSUDS=PSUREFIL(1.1)
.S PSUQTY=+PSUREFIL(1)
.S PSUDRCT=PSUREFIL(1.2)
.S PSURELDT=PSUREFIL(17)
.I PSURELDT'="" S PSURELDT=PSURELDT\1
.S PSURXP=PSUOP(3)
.S PSUDR=PSUOP(6)
.S PSUNDC=""
.I PSUCMOP="Y" D
..S PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)
.I PSUNDC="" S PSUNDC=$$VALI^PSUTL(52.1,"PSURXIEN,PSUFLN",11)
.I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
.D PROVDR^PSUOP3
Q
GETPART ;Get data for Partial Fills
K PSUPART
D GETS^PSUTL(52.2,"PSURXIEN,PSUPFN",".01;.02;.04;.041;.042;.09;6;8","PSUPART","I")
D MOVEI^PSUTL("PSUPART")
S PSUFD=PSUPART(.01)
S PSUPRID=PSUPART(6)
S PSUMW=PSUPART(.02)
S PSUDIVP=PSUPART(.09)
S PSUDS=PSUPART(.041)
S PSUQTY=+PSUPART(.04)
S PSUDRCT=PSUPART(.042)
S PSURELDT=PSUPART(8)
I PSURELDT'="" S PSURELDT=PSURELDT\1
S PSUNDC=$$VALI^PSUTL(52.2,"PSURXIEN,PSUFLN",1)
I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
D PROVDR^PSUOP3 ;Get shared variables
Q
COMVAR ;Get the common variables
D GETS^PSUTL(52,PSURXIEN,".01;2;3;4;6;7;8;11;17;20;22;27;31","PSUOP","I")
D MOVEI^PSUTL("PSUOP")
S PSURXN=PSUOP(.01)
S DFN=PSUOP(2) D PID^VADPT
S PSUSSN=$TR(VA("PID"),"^-","")
S PSUWPC="" ;Patient counseling only exists for version 7.0
S PSUDR=PSUOP(6)
S PSURXP=PSUOP(3)
;S PSUSIG=PSUOP(10)
D GETDRUG^PSUOP3
Q
CMOPARY ;Loop through the "AR" cross reference and build CMOP array
S X1=PSUSDT,X2=-1
D C^%DTC K %,%H,%T
S PSUCDT=X
F S PSUCDT=$O(^PSRX("AR",PSUCDT)) Q:'PSUCDT D
.S PSUCRX=""
.F S PSUCRX=$O(^PSRX("AR",PSUCDT,PSUCRX)) Q:PSUCRX="" D
..S PSUCLN=""
..F S PSUCLN=$O(^PSRX("AR",PSUCDT,PSUCRX,PSUCLN)) Q:PSUCLN="" D
...S ^TMP($J,PSUCRX,PSUCLN)=""
Q
PSUOP1 ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 6.0 ;25 AUG 1998
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ;DBIAs
+4 ; Reference to ^PSRX( file #52 supported by DBIA(s) 465, 2512, 2513
EN ;Entry to data collection
+1 KILL ^TMP($JOB)
+2 DO CMOPARY
DO ADLOOP
+3 QUIT
ADLOOP ;Loop through the AD cross reference
+1 SET X1=PSUSDT
SET X2=-31
+2 DO C^%DTC
KILL %,%H,%T
+3 SET PSUFDT=X
+4 FOR
SET PSUFDT=$ORDER(^PSRX("AD",PSUFDT))
IF PSUFDT=""!(PSUFDT\1>PSUEDT)
QUIT
Begin DoDot:1
+5 SET PSURXIEN=""
+6 FOR
SET PSURXIEN=$ORDER(^PSRX("AD",PSUFDT,PSURXIEN))
IF PSURXIEN=""
QUIT
Begin DoDot:2
+7 SET PSUFIL=""
+8 FOR
SET PSUFIL=$ORDER(^PSRX("AD",PSUFDT,PSURXIEN,PSUFIL))
IF PSUFIL=""
QUIT
Begin DoDot:3
+9 IF '$DATA(^PSRX(PSURXIEN,0))
QUIT
+10 KILL PSUTYP,PSUOP
+11 SET PSUFLN=PSUFIL
+12 DO COMVAR
+13 SET PSUCMOP="N"
+14 ;
+15 ; check for CMOP data
+16 IF $DATA(^PSRX(PSURXIEN,4,0))
DO ARLOOP
+17 ; record filed in subroutine
IF PSUCMOP="Y"
QUIT
+18 IF (PSUFDT\1<PSUSDT)
QUIT
+19 SET PSUTYP=$SELECT(PSUFLN=0:"N",1:"R")
+20 DO GETDATA
+21 DO SETREC^PSUOP3
End DoDot:3
+22 IF $DATA(^PSRX(PSURXIEN,"P",0))
IF '$DATA(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN))
DO ADPLOOP
End DoDot:2
End DoDot:1
+23 KILL ^TMP($JOB)
+24 QUIT
ARLOOP ;Check to see if CMOP Data exists for the reporting period
+1 IF $DATA(^TMP($JOB,PSURXIEN,PSUFLN))
Begin DoDot:1
+2 SET PSUCMOP="Y"
+3 SET PSUTYP=$SELECT(PSUFLN=0:"N",1:"R")
+4 DO GETDATA
+5 IF (PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDT)
QUIT
+6 DO SETREC^PSUOP3
End DoDot:1
+7 QUIT
ADPLOOP ;Get data for partial fills
+1 SET PSUPFN=0
+2 FOR
SET PSUPFN=$ORDER(^PSRX(PSURXIEN,"P",PSUPFN))
IF 'PSUPFN
QUIT
Begin DoDot:1
+3 SET PSUCMOP="N"
+4 DO COMVAR
+5 SET PSUTYP="P"
+6 DO GETPART
+7 IF ((PSUFD<PSUSDT)!(PSUFD>PSUEDT))
QUIT
+8 DO SETREC^PSUOP3
End DoDot:1
+9 QUIT
GETDATA ;Get the data for New Fills, Refills and Partial fills
+1 IF PSUTYP="N"
Begin DoDot:1
+2 SET PSUFD=PSUOP(22)
+3 SET PSUDS=PSUOP(8)
+4 SET PSUQTY=+PSUOP(7)
+5 SET PSUDRCT=PSUOP(17)
+6 SET PSURELDT=PSUOP(31)
+7 IF PSURELDT'=""
SET PSURELDT=PSURELDT\1
+8 SET PSUPRID=PSUOP(4)
+9 SET PSUMW=PSUOP(11)
+10 SET PSUDIVP=PSUOP(20)
+11 SET PSUNDC=""
+12 IF PSUCMOP="Y"
Begin DoDot:2
+13 SET PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)
End DoDot:2
+14 SET PSUNDC=$SELECT(PSUNDC="":PSUOP(27),PSUNDC="":PSUDRUG(31),1:"No NDC")
+15 DO PROVDR^PSUOP3
End DoDot:1
+16 ;Get data for Refills
+17 IF PSUTYP="R"
Begin DoDot:1
+18 DO GETS^PSUTL(52.1,"PSURXIEN,PSUFLN",".01;1;1.1;1.2;2;8;15;17","PSUREFIL","I")
+19 DO MOVEI^PSUTL("PSUREFIL")
+20 SET PSUFD=PSUREFIL(.01)
+21 SET PSUPRID=PSUREFIL(15)
+22 SET PSUMW=PSUREFIL(2)
+23 SET PSUDIVP=PSUREFIL(8)
+24 SET PSUDS=PSUREFIL(1.1)
+25 SET PSUQTY=+PSUREFIL(1)
+26 SET PSUDRCT=PSUREFIL(1.2)
+27 SET PSURELDT=PSUREFIL(17)
+28 IF PSURELDT'=""
SET PSURELDT=PSURELDT\1
+29 SET PSURXP=PSUOP(3)
+30 SET PSUDR=PSUOP(6)
+31 SET PSUNDC=""
+32 IF PSUCMOP="Y"
Begin DoDot:2
+33 SET PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)
End DoDot:2
+34 IF PSUNDC=""
SET PSUNDC=$$VALI^PSUTL(52.1,"PSURXIEN,PSUFLN",11)
+35 IF PSUNDC=""
SET PSUNDC=$SELECT(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
+36 DO PROVDR^PSUOP3
End DoDot:1
KILL REC
+37 QUIT
GETPART ;Get data for Partial Fills
+1 KILL PSUPART
+2 DO GETS^PSUTL(52.2,"PSURXIEN,PSUPFN",".01;.02;.04;.041;.042;.09;6;8","PSUPART","I")
+3 DO MOVEI^PSUTL("PSUPART")
+4 SET PSUFD=PSUPART(.01)
+5 SET PSUPRID=PSUPART(6)
+6 SET PSUMW=PSUPART(.02)
+7 SET PSUDIVP=PSUPART(.09)
+8 SET PSUDS=PSUPART(.041)
+9 SET PSUQTY=+PSUPART(.04)
+10 SET PSUDRCT=PSUPART(.042)
+11 SET PSURELDT=PSUPART(8)
+12 IF PSURELDT'=""
SET PSURELDT=PSURELDT\1
+13 SET PSUNDC=$$VALI^PSUTL(52.2,"PSURXIEN,PSUFLN",1)
+14 IF PSUNDC=""
SET PSUNDC=$SELECT(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
+15 ;Get shared variables
DO PROVDR^PSUOP3
+16 QUIT
COMVAR ;Get the common variables
+1 DO GETS^PSUTL(52,PSURXIEN,".01;2;3;4;6;7;8;11;17;20;22;27;31","PSUOP","I")
+2 DO MOVEI^PSUTL("PSUOP")
+3 SET PSURXN=PSUOP(.01)
+4 SET DFN=PSUOP(2)
DO PID^VADPT
+5 SET PSUSSN=$TRANSLATE(VA("PID"),"^-","")
+6 ;Patient counseling only exists for version 7.0
SET PSUWPC=""
+7 SET PSUDR=PSUOP(6)
+8 SET PSURXP=PSUOP(3)
+9 ;S PSUSIG=PSUOP(10)
+10 DO GETDRUG^PSUOP3
+11 QUIT
CMOPARY ;Loop through the "AR" cross reference and build CMOP array
+1 SET X1=PSUSDT
SET X2=-1
+2 DO C^%DTC
KILL %,%H,%T
+3 SET PSUCDT=X
+4 FOR
SET PSUCDT=$ORDER(^PSRX("AR",PSUCDT))
IF 'PSUCDT
QUIT
Begin DoDot:1
+5 SET PSUCRX=""
+6 FOR
SET PSUCRX=$ORDER(^PSRX("AR",PSUCDT,PSUCRX))
IF PSUCRX=""
QUIT
Begin DoDot:2
+7 SET PSUCLN=""
+8 FOR
SET PSUCLN=$ORDER(^PSRX("AR",PSUCDT,PSUCRX,PSUCLN))
IF PSUCLN=""
QUIT
Begin DoDot:3
+9 SET ^TMP($JOB,PSUCRX,PSUCLN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
