APCLPS1 ; IHS/CMI/LAB - prescription cost report ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;Thanks to Pat Cox who wrote the original code for this report.
;
S APCLL(1)=$$CTR($$USR)
S APCLL(2)=$$CTR($$LOC())
S APCLL(3)=$$CTR("PRESCRIPTION COST REPORT",80)
S APCLL(4)=" "
S APCLL(5)="This report can be used by a site to determine prescription cost"
S APCLL(6)="for a user specified group of patients for a specified date"
S APCLL(7)="range. The report will allow sites to prepare for the Medicare"
S APCLL(8)="Part D Prescription Drug Coverage that begins in January 2006."
S APCLL(9)=""
D EN^DDIOL(.APCLL)
K APCLL
DATES K APCLED,APCLBD
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date"
D ^DIR Q:Y<1 S APCLBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date"
D ^DIR Q:Y<1 S APCLED=Y
;
I APCLED<APCLBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
;
INS ;
K APCLINS
K DIR
S DIR(0)="S^I:With INSURANCE (Medicare, Medicaid or Private Insurance);N:With NO Insurance"
S DIR("A")="Do want to include patients",DIR("B")="I" KILL DA D ^DIR
KILL DIR
I $D(DIRUT) G DATES
S APCLINS=Y
I APCLINS="N" G SOURCE
INST ;
K APCLITYP
W !,"Please select the insurance types that the patient must have to be"
W !,"included in the report. For example, if you want patients with Medicare"
W !,"enter 1, if you want patients with both Medicare and Medicaid, enter 1,2."
W !
W !?10,"1 Medicare"
W !?10,"2 Medicaid"
W !?10,"3 Private Insurance"
S DIR(0)="L^1:3",DIR("A")="Enter Insurance Types that the Patient must have",DIR("B")="1" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G INS
I Y[1 S APCLITYP("M")=""
I Y[2 S APCLITYP("C")=""
I Y[3 S APCLITYP("P")=""
;
SOURCE ;SOURCE OF DOLLAR AMOUNT AWP OR ACTUAL ACQUISTION COST
S APCLSRC=""
K DIR
S DIR("?")=" "
S DIR("?",1)="AVERAGE WHOLESALE PRICE IS THE AWP TIMES THE QTY FOR THE PRESCRIPTION"
S DIR("?",2)="ACTUAL ACQUISITION PRICE IS THE UNIT PRICE TIMES THE QTY FOR THE PRESCRIPTION"
S DIR("?",3)="BILLED PRICE IS THE ACTUAL AMOUNT THE POINT OF SALE PACKAGE BILLED FOR THE RX"
S DIR("?",4)="THIS BILLED PRICE INCLUDES THE DISPENSING FEE"
S DIR("?",5)="RECEIVED PRICE IS THE PRICE THAT WAS ACTUALLY PAID FROM THE VENDOR"
S DIR(0)="S^A:AVERAGE WHOLESALE PRICE;P:ACTUAL ACQUISITION PRICE;B:POS BILLED PRICE;R:POS RECEIVED PRICE"
S DIR("A")="ENTER THE COST TO USE IN CALCULATING COSTS"
D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT)) G INS
I "APBR"'[Y G SOURCE
S APCLSRC=Y
;
DOLLAR ;
S APCLDOLL=""
K DIR
S DIR(0)="N^::2"
S DIR("A")="ENTER THE DOLLAR TRIGGER AMOUNT/MINIMUM TOTAL PRESCRIPTION COST"
D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT)) G SOURCE
I +Y'>0 G DOLLAR
S APCLDOLL=+Y
;
DSPDN ;
S APCLDDN=""
K DIR
S DIR(0)="Y",DIR("A")="Do you wish to display the drug names on the list",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DOLLAR
S APCLDDN=Y
;
SORT ;
S APCLSORT=""
K DIR
S DIR(0)="S^P:Patient Name;H:Health Record (Chart) Number;I:Insurance Type;C:Total Prescription COST"
S DIR("A")="How would you like the report sorted",DIR("B")="P" D ^DIR K DIR
I $D(DIRUT) G DSPDN
S APCLSORT=Y
;
ZIS ; call xbdbque
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G SORT
S XBRP="PRINT^APCLPS1",XBRC="PROC^APCLPS1",XBRX="EOJ^APCLPS1",XBNS="APCL"
D ^XBDBQUE
D EOJ
Q
;
EOJ ;
D EN^XBVK("APCL")
D ^XBFMK
Q
;
PROC ;
S APCLBTH=$H,APCLJOB=$J
K ^XTMP("APCLPS1",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLPS1","PRESCRIPTION COST REPORT")
;first get list of all patients with cost equal to less than APCLDOLL
S APCLSD=$$FMADD^XLFDT(APCLBD,-1)
F S APCLSD=$O(^PSRX("AD",APCLSD)) Q:(APCLSD="")!(APCLSD>APCLED) D
.S APCLRXIN=0 F S APCLRXIN=$O(^PSRX("AD",APCLSD,APCLRXIN)) Q:APCLRXIN="" D
..S APCLRXFL="" F S APCLRXFL=$O(^PSRX("AD",APCLSD,APCLRXIN,APCLRXFL)) Q:APCLRXFL'=+APCLRXFL D
...S APCLRX0=^PSRX(APCLRXIN,0) Q:$$DEMO^APCLUTL($P(APCLRX0,U,2),$G(APCLDEMO))
...D ENP^XBDIQ1(52,APCLRXIN,"2;7;17;13;32.1;31;100;9999999.06","APCLRX(","I")
...D:+APCLRXFL ENP^XBDIQ1(52.1,APCLRXIN_","_APCLRXFL,"1;1.2;14;17;9999999.06","APCLRXR(","I")
...;B "L+"
...Q:APCLRX(100,"I")=13 ;DELETED
...I '+APCLRXFL D ;ORIGINAL RX
....Q:APCLRX(31,"I")']"" ;NOT RELEASED
....Q:APCLRX(32.1,"I")]"" ;RETURNED TO STOCK
....;HERE COMES THE POS STUFF
....D
.....S APCLABSP=APCLRXIN_".00001"
.....S APCLABSI=$O(^ABSPTL("B",APCLABSP,""),-1) ;THE LAST IEN FOR THIS ENTRY IN ABSP LOG OF TRANSACTIONS
.....I '+APCLABSI S APCLBCOS=0,APCLCCOS=0 Q ;APCLBCOS IS THE BILLED POS AND APCLCCOS IS COLLECTED COST
.....D ENP^XBDIQ1(9002313.57,APCLABSI,"505;14;4","APCLPTL(","I") ;4=RESPONSE 14=POS IN CLAIM,505=TOTAL PRICE
.....S APCLBCOS=APCLPTL(505) ;TOTAL PRICE BILLED
.....I '+APCLPTL(4,"I") S APCLCCOS=0 Q
.....D ENP^XBDIQ1(9002313.0301,APCLPTL(4,"I")_","_APCLPTL(14,"I"),509,"ABSPR(")
.....S APCLCCOS=+$TR(ABSPR(509),"$ ","") ;TOTAL PRICE ACTUALLY RECEIVED
....S APCLCOST=$S(APCLSRC="A":APCLRX(9999999.06),APCLSRC="B":APCLBCOS,APCLSRC="R":APCLCCOS,APCLSRC="P":APCLRX(17),1:""),QTY=APCLRX(7),APCLTCOS=$S("AP"[APCLSRC:APCLCOST*QTY,1:APCLCOST)
....;I HATE THIS BUT OF APCLSRC IS B OR R APCLCOST IS FOR FULL AMOUNT NO NEED TO MULTIPLY BY QTY
...I +APCLRXFL D ;ITS A REFILL
....Q:APCLRXR(17,"I")']"" ;NOT RELEASED
....Q:APCLRXR(14,"I")]"" ;RETURNED TO STOCK
....;HERE COMES THE POS STUFF
....D
.....S APCLSUFF=.00001+(+APCLRXFL*.0001) ;GET THE SUFFIX TO ADD
.....S APCLABSP=APCLRXIN_APCLSUFF
.....S APCLABSI=$O(^ABSPTL("B",APCLABSP,""),-1) ;THE LAST IEN FOR THIS ENTRY IN ABSP LOG OF TRANSACTIONS
.....I '+APCLABSI S APCLBCOS=0,APCLCCOS=0 Q ;APCLBCOS IS THE BILLED POS AND APCLCCOS IS COLLECTED COST
.....D ENP^XBDIQ1(9002313.57,APCLABSI,"505;14;4","APCLPTL(","I") ;4=RESPONSE 14=POS IN CLAIM,505=TOTAL PRICE
.....S APCLBCOS=APCLPTL(505) ;TOTAL PRICE BILLED
.....I '+APCLPTL(4,"I") S APCLCCOS=0 Q
.....D ENP^XBDIQ1(9002313.0301,APCLPTL(4,"I")_","_APCLPTL(14,"I"),509,"ABSPR(")
.....S APCLCCOS=+$TR(ABSPR(509),"$ ","") ;TOTAL PRICE ACTUALLY RECEIVED
....;S APCLCOST=$S(APCLSRC="A":APCLRXR(9999999.06),1:APCLRXR(1.2)),QTY=APCLRXR(1),APCLTCOS=APCLCOST*QTY
....S APCLCOST=$S(APCLSRC="A":APCLRX(9999999.06),APCLSRC="B":APCLBCOS,APCLSRC="R":APCLCCOS,APCLSRC="P":APCLRX(17),1:""),QTY=APCLRX(7),APCLTCOS=$S("AP"[APCLSRC:APCLCOST*QTY,1:APCLCOST)
...Q:'$G(APCLTCOS) ;NOT GOT ONE
...S APCLDFN=APCLRX(2,"I")
...S APCLPINS=$$INSTD(APCLDFN,APCLSD,APCLINS,.APCLITYP) I 'APCLPINS K APCLTCOS Q ;quit if the patient did not have insurance on this prescription date
...S APCLSV="" D GETSORT I APCLSV="" S APCLSV="--"
...S ^(0)=$G(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLRX(2,"I"),0))+APCLTCOS
...S ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLRX(2,"I"),"DRUGS",$$VAL^XBDIQ1(52,APCLRXIN,6))=""
...F X=2:1:4 I $P(APCLPINS,U,X)]"" S ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,"INS",$P(APCLPINS,U,X))=""
...K APCLTCOS
;now loop through and eliminate anyone without the dollar amt specified
S APCLSV="" F S APCLSV=$O(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV)) Q:APCLSV="" D
.S APCLDFN=0 F S APCLDFN=$O(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN)) Q:APCLDFN'=+APCLDFN D
..I ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,0)<APCLDOLL K ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN)
Q
;
;
GETSORT ;
S APCLSV=""
I APCLSORT="P" S APCLSV=$P(^DPT(APCLDFN,0),U)
I APCLSORT="H" S APCLSV=$$HRN^AUPNPAT(APCLDFN,DUZ(2))
I APCLSORT="C" S APCLSV=APCLTCOS
I APCLSORT="I" D
.I $$MCR^AUPNPAT(APCLDFN,APCLSD) S APCLSV="Mcare"
.I $$MCD^AUPNPAT(APCLDFN,APCLSD) S APCLSV=APCLSV_$S(APCLSV="":"",1:"/")_"Mcaid"
.I $$PI^AUPNPAT(APCLDFN,APCLSD) S APCLSV=APCLSV_$S(APCLSV="":"",1:"/")_"PI"
.I APCLSV="" S APCLSV="No Insurance"
Q
INSTD(P,D,I,T) ;
I $G(P)="" Q 0
I $G(D)="" Q 0
NEW MCD,MCR,PI
S MCD=$$MCD(P,D)
S MCR=$$MCR(P,D)
S PI=$$PI(P,D)
I I="N",($P(MCD,U)+$P(MCR,U,1)+$P(PI,U,1)) Q 0 ;pt has ins and they want ones that don't
I I="N",'($P(MCD,U)+$P(MCR,U,1)+$P(PI,U,1)) Q 1_"^No insurance" ;want pts with no insurance and this patient has no insurance
I $D(T("M")),'MCR Q 0
I $D(T("P")),'PI Q 0
I $D(T("C")),'MCD Q 0
Q 1_U_$S(MCR:$P(MCR,U,2),1:"")_U_$S(MCD:$P(MCD,U,2),1:"")_U_$S(PI:$P(PI,U,2),1:"")
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:IO'=IO(0)
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
W !
S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
PRINT ;EP - called from xbdbque
;
S APCLPG=0 K APCLQUIT
I '$D(^XTMP("APCLPS1",APCLJOB,APCLBTH)) D HEADER W !!,"No data to report.",! G DONE
D HEADER
S APCLSV="" F S APCLSV=$O(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV)) Q:APCLSV=""!($D(APCLQUIT)) D
.S APCLDFN=0 F S APCLDFN=$O(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN)) Q:APCLDFN'=+APCLDFN!($D(APCLQUIT)) D
..I $Y>(IOSL-4) D HEADER Q:$D(APCLQUIT)
..W !,$P(^DPT(APCLDFN,0),U)
..W ?32,$$HRN^AUPNPAT(APCLDFN,DUZ(2))
..S APCLI="",APCLC=0 F S APCLI=$O(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,"INS",APCLI)) Q:APCLI=""!($D(APCLQUIT)) D
...S APCLC=APCLC+1
...W:APCLC>1 ! W ?41,APCLI
...I APCLC=1 W ?70,$FN(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,0),"",2)
..Q:'APCLDDN
..S APCLD="" F S APCLD=$O(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,"DRUGS",APCLD)) Q:APCLD=""!($D(APCLQUIT)) D
...W !?3,APCLD
D DONE
Q
G:'APCLPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
W !,$$CTR("*** PRESCRIPTION COST REPORT ***",80),!
S X="Prescription Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80),!
S X="Source: "_$S(APCLSRC="A":"AVERAGE WHOLESALE PRICE",APCLSRC="P":"ACTUAL ACQUISITION PRICE",APCLSRC="B":"POS BILLED PRICE",APCLSRC="R":"POS RECEIVED PRICE",1:"??") W $$CTR(X,80),!
S X="Dollar Trigger Amount: "_APCLDOLL W $$CTR(X,80),!
S X=$S(APCLINS="N":"Patient's with NO Insurance",1:"")
I X="" D
.I $D(APCLITYP("M")) S X="Mcare"
.I $D(APCLITYP("C")) S X=X_$S(X="":"",1:"/")_"Mcaid"
.I $D(APCLITYP("P")) S X=X_$S(X="":"",1:"/")_"PI"
S X="Insurance: "_X W $$CTR(X,80),!
W !," Name",?32,"Chart #",?41,"Eligibility Dates",?70,"Total Rx",!?70,"Costs"
W !,$TR($J("",80)," ","-")
Q
DONE ;
K ^XTMP("APCLPS1",APCLJOB,APCLBTH)
D EOP
Q
MCR(P,D) ;EP - Is patient P medicare eligible on date D. 1 = yes, 0 = no.
; I = IEN in ^AUPNMCR multiple.
I '$G(P) Q 0
I '$G(D) Q 0
NEW I,Y
S Y=0,U="^"
I '$D(^DPT(P,0)) G MCRX
I $P(^DPT(P,0),U,19) G MCRX
I '$D(^AUPNPAT(P,0)) G MCRX
I '$D(^AUPNMCR(P,11)) G MCRX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX
S I=0
F S I=$O(^AUPNMCR(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNMCR(P,11,I,0),U)>D
. I $P(^AUPNMCR(P,11,I,0),U,2)]"",$P(^(0),U,2)<D Q
. S Y=1_U_"MCR: "_$$DATE($P(^AUPNMCR(P,11,I,0),U,1))_"-"_$$DATE($P(^AUPNMCR(P,11,I,0),U,2))
.Q
MCRX ;
Q Y
;
;----------
; MCD: Input - P = DFN
; D = Date
; Output - 1 = Yes, patient is/was MCaid eligible on date D.
; 0 = No, or unable.
;
; Examples: I $$MCD^AUPNPAT(DFN,2930701)
; S AGMCD=$$MCD^AUPNPAT(DFN,DT)
;
MCD(P,D) ;EP - Is patient P medicaid eligible on date D.
; I = IEN.
; J = Node 11 IEN in ^AUPNMCD.
I '$G(P) Q 0
I '$G(D) Q 0
NEW I,J,Y
S Y=0,U="^"
I '$D(^DPT(P,0)) G MCDX
I $P(^DPT(P,0),U,19) G MCDX
I '$D(^AUPNPAT(P,0)) G MCDX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDX
S I=0 F S I=$O(^AUPNMCD("B",P,I)) Q:I'=+I D
.Q:'$D(^AUPNMCD(I,11))
.S J=0 F S J=$O(^AUPNMCD(I,11,J)) Q:J'=+J D
..Q:J>D
..I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<D Q
..S Y=1_U_"MCD: "_$$DATE($P(^AUPNMCD(I,11,J,0),U,1))_"-"_$$DATE($P(^AUPNMCD(I,11,J,0),U,2))
..Q
.Q
;
MCDX ;
Q Y
;
;
;----------
; PI: Input - P = DFN
; D = Date
; Output - 1 = Yes, patient is/was PI eligible on date D.
; 0 = No, or unable.
;
; Examples: I $$PI^AUPNPAT(DFN,2930701)
; S AGPI=$$PI^AUPNPAT(DFN,DT)
;
PI(P,D) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
; I = IEN
; Y = 1:yes, 0:no
; X = Pointer to INSURER file.
I '$G(P) Q 0
I '$G(D) Q 0
NEW I,Y,X
S Y=0,U="^"
I '$D(^DPT(P,0)) G PIX
I $P(^DPT(P,0),U,19) G PIX
I '$D(^AUPNPAT(P,0)) G PIX
I '$D(^AUPNPRVT(P,11)) G PIX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX
S I=0
F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNPRVT(P,11,I,0),U)=""
. S X=$P(^AUPNPRVT(P,11,I,0),U) Q:X=""
. Q:$P(^AUTNINS(X,0),U)["AHCCCS"
. Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
. I $P(^AUPNPRVT(P,11,I,0),U,7)]"",$P(^(0),U,7)<D Q
. S Y=1_U_"PI: "_$$DATE($P(^AUPNPRVT(P,11,I,0),U,6))_"-"_$$DATE($P(^AUPNPRVT(P,11,I,0),U,7))
.Q
PIX ;
Q Y
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+($E(D,1,3)))
;
APCLPS1 ; IHS/CMI/LAB - prescription cost report ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;Thanks to Pat Cox who wrote the original code for this report.
+4 ;
+5 SET APCLL(1)=$$CTR($$USR)
+6 SET APCLL(2)=$$CTR($$LOC())
+7 SET APCLL(3)=$$CTR("PRESCRIPTION COST REPORT",80)
+8 SET APCLL(4)=" "
+9 SET APCLL(5)="This report can be used by a site to determine prescription cost"
+10 SET APCLL(6)="for a user specified group of patients for a specified date"
+11 SET APCLL(7)="range. The report will allow sites to prepare for the Medicare"
+12 SET APCLL(8)="Part D Prescription Drug Coverage that begins in January 2006."
+13 SET APCLL(9)=""
+14 DO EN^DDIOL(.APCLL)
+15 KILL APCLL
DATES KILL APCLED,APCLBD
+1 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date"
+2 DO ^DIR
IF Y<1
QUIT
SET APCLBD=Y
+3 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Date"
+4 DO ^DIR
IF Y<1
QUIT
SET APCLED=Y
+5 ;
+6 IF APCLED<APCLBD
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+8 ;
+9 ;
INS ;
+1 KILL APCLINS
+2 KILL DIR
+3 SET DIR(0)="S^I:With INSURANCE (Medicare, Medicaid or Private Insurance);N:With NO Insurance"
+4 SET DIR("A")="Do want to include patients"
SET DIR("B")="I"
KILL DA
DO ^DIR
+5 KILL DIR
+6 IF $DATA(DIRUT)
GOTO DATES
+7 SET APCLINS=Y
+8 IF APCLINS="N"
GOTO SOURCE
INST ;
+1 KILL APCLITYP
+2 WRITE !,"Please select the insurance types that the patient must have to be"
+3 WRITE !,"included in the report. For example, if you want patients with Medicare"
+4 WRITE !,"enter 1, if you want patients with both Medicare and Medicaid, enter 1,2."
+5 WRITE !
+6 WRITE !?10,"1 Medicare"
+7 WRITE !?10,"2 Medicaid"
+8 WRITE !?10,"3 Private Insurance"
+9 SET DIR(0)="L^1:3"
SET DIR("A")="Enter Insurance Types that the Patient must have"
SET DIR("B")="1"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
GOTO INS
+11 IF Y[1
SET APCLITYP("M")=""
+12 IF Y[2
SET APCLITYP("C")=""
+13 IF Y[3
SET APCLITYP("P")=""
+14 ;
SOURCE ;SOURCE OF DOLLAR AMOUNT AWP OR ACTUAL ACQUISTION COST
+1 SET APCLSRC=""
+2 KILL DIR
+3 SET DIR("?")=" "
+4 SET DIR("?",1)="AVERAGE WHOLESALE PRICE IS THE AWP TIMES THE QTY FOR THE PRESCRIPTION"
+5 SET DIR("?",2)="ACTUAL ACQUISITION PRICE IS THE UNIT PRICE TIMES THE QTY FOR THE PRESCRIPTION"
+6 SET DIR("?",3)="BILLED PRICE IS THE ACTUAL AMOUNT THE POINT OF SALE PACKAGE BILLED FOR THE RX"
+7 SET DIR("?",4)="THIS BILLED PRICE INCLUDES THE DISPENSING FEE"
+8 SET DIR("?",5)="RECEIVED PRICE IS THE PRICE THAT WAS ACTUALLY PAID FROM THE VENDOR"
+9 SET DIR(0)="S^A:AVERAGE WHOLESALE PRICE;P:ACTUAL ACQUISITION PRICE;B:POS BILLED PRICE;R:POS RECEIVED PRICE"
+10 SET DIR("A")="ENTER THE COST TO USE IN CALCULATING COSTS"
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO INS
+13 IF "APBR"'[Y
GOTO SOURCE
+14 SET APCLSRC=Y
+15 ;
DOLLAR ;
+1 SET APCLDOLL=""
+2 KILL DIR
+3 SET DIR(0)="N^::2"
+4 SET DIR("A")="ENTER THE DOLLAR TRIGGER AMOUNT/MINIMUM TOTAL PRESCRIPTION COST"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO SOURCE
+7 IF +Y'>0
GOTO DOLLAR
+8 SET APCLDOLL=+Y
+9 ;
DSPDN ;
+1 SET APCLDDN=""
+2 KILL DIR
+3 SET DIR(0)="Y"
SET DIR("A")="Do you wish to display the drug names on the list"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DOLLAR
+5 SET APCLDDN=Y
+6 ;
SORT ;
+1 SET APCLSORT=""
+2 KILL DIR
+3 SET DIR(0)="S^P:Patient Name;H:Health Record (Chart) Number;I:Insurance Type;C:Total Prescription COST"
+4 SET DIR("A")="How would you like the report sorted"
SET DIR("B")="P"
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO DSPDN
+6 SET APCLSORT=Y
+7 ;
ZIS ; call xbdbque
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO SORT
+3 SET XBRP="PRINT^APCLPS1"
SET XBRC="PROC^APCLPS1"
SET XBRX="EOJ^APCLPS1"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 DO EOJ
+6 QUIT
+7 ;
EOJ ;
+1 DO EN^XBVK("APCL")
+2 DO ^XBFMK
+3 QUIT
+4 ;
PROC ;
+1 SET APCLBTH=$HOROLOG
SET APCLJOB=$JOB
+2 KILL ^XTMP("APCLPS1",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLPS1","PRESCRIPTION COST REPORT")
+4 ;first get list of all patients with cost equal to less than APCLDOLL
+5 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)
+6 FOR
SET APCLSD=$ORDER(^PSRX("AD",APCLSD))
IF (APCLSD="")!(APCLSD>APCLED)
QUIT
Begin DoDot:1
+7 SET APCLRXIN=0
FOR
SET APCLRXIN=$ORDER(^PSRX("AD",APCLSD,APCLRXIN))
IF APCLRXIN=""
QUIT
Begin DoDot:2
+8 SET APCLRXFL=""
FOR
SET APCLRXFL=$ORDER(^PSRX("AD",APCLSD,APCLRXIN,APCLRXFL))
IF APCLRXFL'=+APCLRXFL
QUIT
Begin DoDot:3
+9 SET APCLRX0=^PSRX(APCLRXIN,0)
IF $$DEMO^APCLUTL($PIECE(APCLRX0,U,2),$GET(APCLDEMO))
QUIT
+10 DO ENP^XBDIQ1(52,APCLRXIN,"2;7;17;13;32.1;31;100;9999999.06","APCLRX(","I")
+11 IF +APCLRXFL
DO ENP^XBDIQ1(52.1,APCLRXIN_","_APCLRXFL,"1;1.2;14;17;9999999.06","APCLRXR(","I")
+12 ;B "L+"
+13 ;DELETED
IF APCLRX(100,"I")=13
QUIT
+14 ;ORIGINAL RX
IF '+APCLRXFL
Begin DoDot:4
+15 ;NOT RELEASED
IF APCLRX(31,"I")']""
QUIT
+16 ;RETURNED TO STOCK
IF APCLRX(32.1,"I")]""
QUIT
+17 ;HERE COMES THE POS STUFF
+18 Begin DoDot:5
+19 SET APCLABSP=APCLRXIN_".00001"
+20 ;THE LAST IEN FOR THIS ENTRY IN ABSP LOG OF TRANSACTIONS
SET APCLABSI=$ORDER(^ABSPTL("B",APCLABSP,""),-1)
+21 ;APCLBCOS IS THE BILLED POS AND APCLCCOS IS COLLECTED COST
IF '+APCLABSI
SET APCLBCOS=0
SET APCLCCOS=0
QUIT
+22 ;4=RESPONSE 14=POS IN CLAIM,505=TOTAL PRICE
DO ENP^XBDIQ1(9002313.57,APCLABSI,"505;14;4","APCLPTL(","I")
+23 ;TOTAL PRICE BILLED
SET APCLBCOS=APCLPTL(505)
+24 IF '+APCLPTL(4,"I")
SET APCLCCOS=0
QUIT
+25 DO ENP^XBDIQ1(9002313.0301,APCLPTL(4,"I")_","_APCLPTL(14,"I"),509,"ABSPR(")
+26 ;TOTAL PRICE ACTUALLY RECEIVED
SET APCLCCOS=+$TRANSLATE(ABSPR(509),"$ ","")
End DoDot:5
+27 SET APCLCOST=$SELECT(APCLSRC="A":APCLRX(9999999.06),APCLSRC="B":APCLBCOS,APCLSRC="R":APCLCCOS,APCLSRC="P":APCLRX(17),1:"")
SET QTY=APCLRX(7)
SET APCLTCOS=$SELECT("AP"[APCLSRC:APCLCOST*QTY,1:APCLCOST)
+28 ;I HATE THIS BUT OF APCLSRC IS B OR R APCLCOST IS FOR FULL AMOUNT NO NEED TO MULTIPLY BY QTY
End DoDot:4
+29 ;ITS A REFILL
IF +APCLRXFL
Begin DoDot:4
+30 ;NOT RELEASED
IF APCLRXR(17,"I")']""
QUIT
+31 ;RETURNED TO STOCK
IF APCLRXR(14,"I")]""
QUIT
+32 ;HERE COMES THE POS STUFF
+33 Begin DoDot:5
+34 ;GET THE SUFFIX TO ADD
SET APCLSUFF=.00001+(+APCLRXFL*.0001)
+35 SET APCLABSP=APCLRXIN_APCLSUFF
+36 ;THE LAST IEN FOR THIS ENTRY IN ABSP LOG OF TRANSACTIONS
SET APCLABSI=$ORDER(^ABSPTL("B",APCLABSP,""),-1)
+37 ;APCLBCOS IS THE BILLED POS AND APCLCCOS IS COLLECTED COST
IF '+APCLABSI
SET APCLBCOS=0
SET APCLCCOS=0
QUIT
+38 ;4=RESPONSE 14=POS IN CLAIM,505=TOTAL PRICE
DO ENP^XBDIQ1(9002313.57,APCLABSI,"505;14;4","APCLPTL(","I")
+39 ;TOTAL PRICE BILLED
SET APCLBCOS=APCLPTL(505)
+40 IF '+APCLPTL(4,"I")
SET APCLCCOS=0
QUIT
+41 DO ENP^XBDIQ1(9002313.0301,APCLPTL(4,"I")_","_APCLPTL(14,"I"),509,"ABSPR(")
+42 ;TOTAL PRICE ACTUALLY RECEIVED
SET APCLCCOS=+$TRANSLATE(ABSPR(509),"$ ","")
End DoDot:5
+43 ;S APCLCOST=$S(APCLSRC="A":APCLRXR(9999999.06),1:APCLRXR(1.2)),QTY=APCLRXR(1),APCLTCOS=APCLCOST*QTY
+44 SET APCLCOST=$SELECT(APCLSRC="A":APCLRX(9999999.06),APCLSRC="B":APCLBCOS,APCLSRC="R":APCLCCOS,APCLSRC="P":APCLRX(17),1:"")
SET QTY=APCLRX(7)
SET APCLTCOS=$SELECT("AP"[APCLSRC:APCLCOST*QTY,1:APCLCOST)
End DoDot:4
+45 ;NOT GOT ONE
IF '$GET(APCLTCOS)
QUIT
+46 SET APCLDFN=APCLRX(2,"I")
+47 ;quit if the patient did not have insurance on this prescription date
SET APCLPINS=$$INSTD(APCLDFN,APCLSD,APCLINS,.APCLITYP)
IF 'APCLPINS
KILL APCLTCOS
QUIT
+48 SET APCLSV=""
DO GETSORT
IF APCLSV=""
SET APCLSV="--"
+49 SET ^(0)=$GET(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLRX(2,"I"),0))+APCLTCOS
+50 SET ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLRX(2,"I"),"DRUGS",$$VAL^XBDIQ1(52,APCLRXIN,6))=""
+51 FOR X=2:1:4
IF $PIECE(APCLPINS,U,X)]""
SET ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,"INS",$PIECE(APCLPINS,U,X))=""
+52 KILL APCLTCOS
End DoDot:3
End DoDot:2
End DoDot:1
+53 ;now loop through and eliminate anyone without the dollar amt specified
+54 SET APCLSV=""
FOR
SET APCLSV=$ORDER(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV))
IF APCLSV=""
QUIT
Begin DoDot:1
+55 SET APCLDFN=0
FOR
SET APCLDFN=$ORDER(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN))
IF APCLDFN'=+APCLDFN
QUIT
Begin DoDot:2
+56 IF ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,0)<APCLDOLL
KILL ^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN)
End DoDot:2
End DoDot:1
+57 QUIT
+58 ;
+59 ;
GETSORT ;
+1 SET APCLSV=""
+2 IF APCLSORT="P"
SET APCLSV=$PIECE(^DPT(APCLDFN,0),U)
+3 IF APCLSORT="H"
SET APCLSV=$$HRN^AUPNPAT(APCLDFN,DUZ(2))
+4 IF APCLSORT="C"
SET APCLSV=APCLTCOS
+5 IF APCLSORT="I"
Begin DoDot:1
+6 IF $$MCR^AUPNPAT(APCLDFN,APCLSD)
SET APCLSV="Mcare"
+7 IF $$MCD^AUPNPAT(APCLDFN,APCLSD)
SET APCLSV=APCLSV_$SELECT(APCLSV="":"",1:"/")_"Mcaid"
+8 IF $$PI^AUPNPAT(APCLDFN,APCLSD)
SET APCLSV=APCLSV_$SELECT(APCLSV="":"",1:"/")_"PI"
+9 IF APCLSV=""
SET APCLSV="No Insurance"
End DoDot:1
+10 QUIT
INSTD(P,D,I,T) ;
+1 IF $GET(P)=""
QUIT 0
+2 IF $GET(D)=""
QUIT 0
+3 NEW MCD,MCR,PI
+4 SET MCD=$$MCD(P,D)
+5 SET MCR=$$MCR(P,D)
+6 SET PI=$$PI(P,D)
+7 ;pt has ins and they want ones that don't
IF I="N"
IF ($PIECE(MCD,U)+$PIECE(MCR,U,1)+$PIECE(PI,U,1))
QUIT 0
+8 ;want pts with no insurance and this patient has no insurance
IF I="N"
IF '($PIECE(MCD,U)+$PIECE(MCR,U,1)+$PIECE(PI,U,1))
QUIT 1_"^No insurance"
+9 IF $DATA(T("M"))
IF 'MCR
QUIT 0
+10 IF $DATA(T("P"))
IF 'PI
QUIT 0
+11 IF $DATA(T("C"))
IF 'MCD
QUIT 0
+12 QUIT 1_U_$SELECT(MCR:$PIECE(MCR,U,2),1:"")_U_$SELECT(MCD:$PIECE(MCD,U,2),1:"")_U_$SELECT(PI:$PIECE(PI,U,2),1:"")
+13 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF IO'=IO(0)
QUIT
+3 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+4 NEW DIR
+5 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+6 WRITE !
+7 SET DIR("A")="End of Report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+8 QUIT
+9 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
PRINT ;EP - called from xbdbque
+1 ;
+2 SET APCLPG=0
KILL APCLQUIT
+3 IF '$DATA(^XTMP("APCLPS1",APCLJOB,APCLBTH))
DO HEADER
WRITE !!,"No data to report.",!
GOTO DONE
+4 DO HEADER
+5 SET APCLSV=""
FOR
SET APCLSV=$ORDER(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV))
IF APCLSV=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+6 SET APCLDFN=0
FOR
SET APCLDFN=$ORDER(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN))
IF APCLDFN'=+APCLDFN!($DATA(APCLQUIT))
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-4)
DO HEADER
IF $DATA(APCLQUIT)
QUIT
+8 WRITE !,$PIECE(^DPT(APCLDFN,0),U)
+9 WRITE ?32,$$HRN^AUPNPAT(APCLDFN,DUZ(2))
+10 SET APCLI=""
SET APCLC=0
FOR
SET APCLI=$ORDER(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,"INS",APCLI))
IF APCLI=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:3
+11 SET APCLC=APCLC+1
+12 IF APCLC>1
WRITE !
WRITE ?41,APCLI
+13 IF APCLC=1
WRITE ?70,$FNUMBER(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,0),"",2)
End DoDot:3
+14 IF 'APCLDDN
QUIT
+15 SET APCLD=""
FOR
SET APCLD=$ORDER(^XTMP("APCLPS1",APCLJOB,APCLBTH,APCLSV,APCLDFN,"DRUGS",APCLD))
IF APCLD=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:3
+16 WRITE !?3,APCLD
End DoDot:3
End DoDot:2
End DoDot:1
+17 DO DONE
+18 QUIT
+1 IF 'APCLPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
+3 WRITE !,$$CTR("*** PRESCRIPTION COST REPORT ***",80),!
+4 SET X="Prescription Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80),!
+5 SET X="Source: "_$SELECT(APCLSRC="A":"AVERAGE WHOLESALE PRICE",APCLSRC="P":"ACTUAL ACQUISITION PRICE",APCLSRC="B":"POS BILLED PRICE",APCLSRC="R":"POS RECEIVED PRICE",1:"??")
WRITE $$CTR(X,80),!
+6 SET X="Dollar Trigger Amount: "_APCLDOLL
WRITE $$CTR(X,80),!
+7 SET X=$SELECT(APCLINS="N":"Patient's with NO Insurance",1:"")
+8 IF X=""
Begin DoDot:1
+9 IF $DATA(APCLITYP("M"))
SET X="Mcare"
+10 IF $DATA(APCLITYP("C"))
SET X=X_$SELECT(X="":"",1:"/")_"Mcaid"
+11 IF $DATA(APCLITYP("P"))
SET X=X_$SELECT(X="":"",1:"/")_"PI"
End DoDot:1
+12 SET X="Insurance: "_X
WRITE $$CTR(X,80),!
+13 WRITE !," Name",?32,"Chart #",?41,"Eligibility Dates",?70,"Total Rx",!?70,"Costs"
+14 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+15 QUIT
DONE ;
+1 KILL ^XTMP("APCLPS1",APCLJOB,APCLBTH)
+2 DO EOP
+3 QUIT
MCR(P,D) ;EP - Is patient P medicare eligible on date D. 1 = yes, 0 = no.
+1 ; I = IEN in ^AUPNMCR multiple.
+2 IF '$GET(P)
QUIT 0
+3 IF '$GET(D)
QUIT 0
+4 NEW I,Y
+5 SET Y=0
SET U="^"
+6 IF '$DATA(^DPT(P,0))
GOTO MCRX
+7 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+8 IF '$DATA(^AUPNPAT(P,0))
GOTO MCRX
+9 IF '$DATA(^AUPNMCR(P,11))
GOTO MCRX
+10 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+11 SET I=0
+12 FOR
SET I=$ORDER(^AUPNMCR(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+13 IF $PIECE(^AUPNMCR(P,11,I,0),U)>D
QUIT
+14 IF $PIECE(^AUPNMCR(P,11,I,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+15 SET Y=1_U_"MCR: "_$$DATE($PIECE(^AUPNMCR(P,11,I,0),U,1))_"-"_$$DATE($PIECE(^AUPNMCR(P,11,I,0),U,2))
+16 QUIT
End DoDot:1
MCRX ;
+1 QUIT Y
+2 ;
+3 ;----------
+4 ; MCD: Input - P = DFN
+5 ; D = Date
+6 ; Output - 1 = Yes, patient is/was MCaid eligible on date D.
+7 ; 0 = No, or unable.
+8 ;
+9 ; Examples: I $$MCD^AUPNPAT(DFN,2930701)
+10 ; S AGMCD=$$MCD^AUPNPAT(DFN,DT)
+11 ;
MCD(P,D) ;EP - Is patient P medicaid eligible on date D.
+1 ; I = IEN.
+2 ; J = Node 11 IEN in ^AUPNMCD.
+3 IF '$GET(P)
QUIT 0
+4 IF '$GET(D)
QUIT 0
+5 NEW I,J,Y
+6 SET Y=0
SET U="^"
+7 IF '$DATA(^DPT(P,0))
GOTO MCDX
+8 IF $PIECE(^DPT(P,0),U,19)
GOTO MCDX
+9 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDX
+10 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCDX
+11 SET I=0
FOR
SET I=$ORDER(^AUPNMCD("B",P,I))
IF I'=+I
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNMCD(I,11))
QUIT
+13 SET J=0
FOR
SET J=$ORDER(^AUPNMCD(I,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+14 IF J>D
QUIT
+15 IF $PIECE(^AUPNMCD(I,11,J,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+16 SET Y=1_U_"MCD: "_$$DATE($PIECE(^AUPNMCD(I,11,J,0),U,1))_"-"_$$DATE($PIECE(^AUPNMCD(I,11,J,0),U,2))
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 ;
MCDX ;
+1 QUIT Y
+2 ;
+3 ;
+4 ;----------
+5 ; PI: Input - P = DFN
+6 ; D = Date
+7 ; Output - 1 = Yes, patient is/was PI eligible on date D.
+8 ; 0 = No, or unable.
+9 ;
+10 ; Examples: I $$PI^AUPNPAT(DFN,2930701)
+11 ; S AGPI=$$PI^AUPNPAT(DFN,DT)
+12 ;
PI(P,D) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
+1 ; I = IEN
+2 ; Y = 1:yes, 0:no
+3 ; X = Pointer to INSURER file.
+4 IF '$GET(P)
QUIT 0
+5 IF '$GET(D)
QUIT 0
+6 NEW I,Y,X
+7 SET Y=0
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO PIX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO PIX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO PIX
+11 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIX
+12 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIX
+13 SET I=0
+14 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+15 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+16 SET X=$PIECE(^AUPNPRVT(P,11,I,0),U)
IF X=""
QUIT
+17 IF $PIECE(^AUTNINS(X,0),U)["AHCCCS"
QUIT
+18 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+19 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+20 SET Y=1_U_"PI: "_$$DATE($PIECE(^AUPNPRVT(P,11,I,0),U,6))_"-"_$$DATE($PIECE(^AUPNPRVT(P,11,I,0),U,7))
+21 QUIT
End DoDot:1
PIX ;
+1 QUIT Y
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+($EXTRACT(D,1,3)))
+3 ;
