PSOCIDC2 ;BIR/LE-continuation of Copay Correction of erroneous billed copays ;11/8/05 12:50pm
;;7.0;OUTPATIENT PHARMACY;**226,225**;DEC 1997;Build 29
;External reference to ^XUSEC supported by DBIA 10076
;External reference to IBARX supported by DBIA 125
;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
;
TOTAL ;
N COUNT,COUNTED,UCOUNT,UCOUNTED,CCOUNT,CCOUNTED
I '$D(PSOVETS) S PSOVETS=0
N I,J
F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I),PSOCNT("YR2006",I))=0
S PSODFN=0 F S PSODFN=$O(^XTMP(NAMSP,"TOT REL",PSODFN)) Q:'PSODFN D
.S COUNTED=0
.F J="YR2004","YR2005","YR2006" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
F I=1:1:3 S PSOCNT=PSOCNT+$G(PSOCNT("YR2004",I))+$G(PSOCNT("YR2005",I))+$G(PSOCNT("YR2006",I))
;
S (I,J)=-""
I '$D(PSOCVETS) S PSOCVETS=0
F I=1:1:3 S (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0
S PSODFN=0 F S PSODFN=$O(^XTMP(NAMSP,"TOT CAN",PSODFN)) Q:'PSODFN D
.S CCOUNTED=0
.F J="YR2004","YR2005","YR2006" F I=1:1:3 S CCOUNT=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I)) I CCOUNT>0 S:'$G(CCOUNTED) CCOUNTED=1,PSOCVETS=PSOCVETS+1 S PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT
F I=1:1:3 S PSOCCNT=PSOCCNT+$G(PSOCCNT("YR2004",I))+$G(PSOCCNT("YR2005",I))+$G(PSOCCNT("YR2006",I))
;
S (I,J)=""
I '$D(PSOUVETS) S PSOUVETS=0
F I=1:1:3 S (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0
S PSOUDFN=0 F S PSOUDFN=$O(^XTMP(NAMSP,"TOT UNREL",PSOUDFN)) Q:'PSOUDFN D
.S UCOUNTED=0
.F J="YR2004","YR2005","YR2006" F I=1:1:3 S UCOUNT=$G(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I)) I UCOUNT>0 S:'$G(UCOUNTED) UCOUNTED=1,PSOUVETS=PSOUVETS+1 S PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT
F I=1:1:3 S PSOUCNT=PSOUCNT+$G(PSOUCNT("YR2004",I))+$G(PSOUCNT("YR2005",I))+$G(PSOUCNT("YR2006",I))
;
Q
;
CHECK ;check for ICD and IB nodes
;
N PSOREF,PSOIB,PSOOICD,PSOBILLD
S PSOREF=YY
S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8)
; see if bill already exists
I PSOREF=0 D
. I +$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
. S PSOREL=$P($G(^PSRX(RXP,2)),"^",13)
I PSOREF>0 D
. I +$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
. S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
; if billed/RELEASED and no IBQ node for both sc<50 and nsc
I $G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
. I $TR(PSOOICD,"^")[1 S ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
. I $TR(PSOOICD,"^")[0 S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
; find unbilled ones with an ICD node and no IBQ node.
I '$G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
. Q:$TR(PSOOICD,"^")=""
. S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
I YY S PSOTRF=PSOTRF+1
Q
;
CANCEL ;Cancel erroneous copays/set IBQ node if not there
;released rx's
N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE
N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB
N I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL
S PSOTYPE="CAN"
S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"CANCEL",PSODFN)) Q:'PSODFN D Q:STOP
.I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q
.. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
.S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
.F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP)) Q:'RXP D
..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
..S YY="" F S YY=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) Q:YY="" D
...S (SAVREF,PSOREF)=YY
...; verify again that it was billed and not already cancelled
...S PSOBILLD=0
...I YY=0,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
...I YY>0,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^")>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
...Q:'PSOBILLD
...S PSOREL=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3)
...S PSO=3 D NOW^%DTC S PSODT=%,PSODA=RXP,PSOCOMM="-BKGD CIDC COPAY CANCEL",PSOOLD="",PSONW="",PREA=""
...D CHKACT
...S PSOIB="",PSOIB=$S(PSOREF>0:$G(^PSRX(RXP,1,YY,"IB")),'PSOREF:$G(^PSRX(PSODA,"IB")),1:"")
...S (PSOOIBQ,PSOOICD,PSOOIB)=""
...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ
...D SITE S PSOCOMM="-BKGD CIDC COPAY CANCEL" D RXED^PSOCPA S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
...D ACCUM
;
;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased.
S PSOTYP="IBQ"
S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"NOIBQ",PSODFN)) Q:'PSODFN D Q:STOP
.I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q
.. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
.S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
.F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP)) Q:'RXP D
..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
..S YY="" F S YY=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)) Q:YY="" D
...S (SAVREF,PSOREF)=YY
...D SITE
...S PSOREL=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3)
...S (PSOOIBQ,PSOOICD,PSOOIB)=""
...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ D ;don't want to set again if already did it as part of copay cancel
....S I="",IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I S IFN=I
....S COM=" BKGD CIDC UPDATE"
....D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM
....K DA
....S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
...D:'$G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) ACCUM
...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
Q
;
CHKACT ;check activity log for prev entry
N ZACT,ZPSI,ZACTI
S ZPSI=0 F S ZPSI=$O(^PSRX(PSODA,"COPAY",ZPSI)) Q:ZPSI="" S ZACTI="",ZACTI=$G(^PSRX(PSODA,"COPAY",ZPSI,0)) D Q:$G(ZACT)
. I ZACTI["BKGD CIDC COPAY CANCEL"&($P(ZACTI,"^",2)="R") S PSOOLD="",PSONW="",PREA="C",ZACT=1 Q
I '$G(ZACT) S PSOOLD="Copay",PSONW="No Copay",PREA="R" K PSOREF D ACTLOG^PSOCPA S PSOREF=YY,PSOOLD="",PSONW="",PREA="C"
Q
;
SETIBQ ; get data from IBQ node, set IBQ node, and 1st piece of IB node
K PSOANSQ
N PSONIBQ
F PSOTYP=1:1:8 D
. I PSOTYP=1 S PSOANSQ("VEH")=$P(PSOOICD,"^",PSOTYP)
. I PSOTYP=2 S PSOANSQ("RAD")=$P(PSOOICD,"^",PSOTYP)
. I PSOTYP=3 S PSOANSQ("SC")=$P(PSOOICD,"^",PSOTYP)
. I PSOTYP=4 S PSOANSQ("PGW")=$P(PSOOICD,"^",PSOTYP)
. I PSOTYP=5 S PSOANSQ("MST")=$P(PSOOICD,"^",PSOTYP)
. I PSOTYP=6 S PSOANSQ("HNC")=$P(PSOOICD,"^",PSOTYP)
. I PSOTYP=7 S PSOANSQ("CV")=$P(PSOOICD,"^",PSOTYP)
. I PSOTYP=8 S PSOANSQ("SHAD")=$P(PSOOICD,"^",PSOTYP)
S ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV")_"^"_PSOANSQ("SHAD")
Q
;
ACCUM ; ACCUMULATE TOTALS
S (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)=""
; get finished, but unreleased totals
I PSOREL="" S PSOYR=$E(PSOFLD,1,3) Q:PSOYR="" D S PSOYEAR="" Q
.S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") Q:PSOYEAR=""
.S PSOCHRG=7
.I PSOYEAR="YR2006" S PSOCHRG=8
.S PSOTOT=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR))
.S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
.S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1
.S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
.S PSONAM=$E(PSONAM,1,6)
.S ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD
;for released ones
S PSOYR=$E(PSOREL,1,3)
S:PSOYR'="" PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"")
Q:PSOYEAR=""
S PSOCHRG=7
I PSOYEAR="YR2006" S PSOCHRG=8
;
;get Xtmp billing amt which would be IBAM tot + any previous refills
S PSOTOT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR))
;
;if none yet then init to the IBAM total for the year
I 'PSOTOT D
.F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ D
..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
;
;update Xtmp tot nodes with current fill amounts
; note: cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3
; routine. Cancelled copays are denoted with an asterisk.
S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1
;
;indicate COPAY CANCEL for this fill
; ;by adding to Xtmp "BILLED"
S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
S PSONAM=$E(PSONAM,1,6)
S ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
;
CAN I PSOTYPE="CAN"&($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))) N PSOFILL S CANCEL="" S PSOFILL=YY D CHK^PSOCIDC3 I CANCEL D
. S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
. S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1
Q
;
SITE ; SET UP VARIABLES NEEDED BY BILLING
S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
Q:PSOSITE=""
S PSOPAR=$G(^PS(59,PSOSITE,1))
S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCIDC2 9918 printed Dec 13, 2024@02:25:17 Page 2
PSOCIDC2 ;BIR/LE-continuation of Copay Correction of erroneous billed copays ;11/8/05 12:50pm
+1 ;;7.0;OUTPATIENT PHARMACY;**226,225**;DEC 1997;Build 29
+2 ;External reference to ^XUSEC supported by DBIA 10076
+3 ;External reference to IBARX supported by DBIA 125
+4 ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
+5 ;
TOTAL ;
+1 NEW COUNT,COUNTED,UCOUNT,UCOUNTED,CCOUNT,CCOUNTED
+2 IF '$DATA(PSOVETS)
SET PSOVETS=0
+3 NEW I,J
+4 FOR I=1:1:3
SET (PSOCNT("YR2004",I),PSOCNT("YR2005",I),PSOCNT("YR2006",I))=0
+5 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^XTMP(NAMSP,"TOT REL",PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+6 SET COUNTED=0
+7 FOR J="YR2004","YR2005","YR2006"
FOR I=1:1:3
SET COUNT=$GET(^XTMP(NAMSP,"TOT REL",PSODFN,J,I))
IF COUNT>0
if '$GET(COUNTED)
SET COUNTED=1
SET PSOVETS=PSOVETS+1
SET PSOCNT(J,I)=PSOCNT(J,I)+COUNT
End DoDot:1
+8 FOR I=1:1:3
SET PSOCNT=PSOCNT+$GET(PSOCNT("YR2004",I))+$GET(PSOCNT("YR2005",I))+$GET(PSOCNT("YR2006",I))
+9 ;
+10 SET (I,J)=-""
+11 IF '$DATA(PSOCVETS)
SET PSOCVETS=0
+12 FOR I=1:1:3
SET (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0
+13 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^XTMP(NAMSP,"TOT CAN",PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+14 SET CCOUNTED=0
+15 FOR J="YR2004","YR2005","YR2006"
FOR I=1:1:3
SET CCOUNT=$GET(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I))
IF CCOUNT>0
if '$GET(CCOUNTED)
SET CCOUNTED=1
SET PSOCVETS=PSOCVETS+1
SET PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT
End DoDot:1
+16 FOR I=1:1:3
SET PSOCCNT=PSOCCNT+$GET(PSOCCNT("YR2004",I))+$GET(PSOCCNT("YR2005",I))+$GET(PSOCCNT("YR2006",I))
+17 ;
+18 SET (I,J)=""
+19 IF '$DATA(PSOUVETS)
SET PSOUVETS=0
+20 FOR I=1:1:3
SET (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0
+21 SET PSOUDFN=0
FOR
SET PSOUDFN=$ORDER(^XTMP(NAMSP,"TOT UNREL",PSOUDFN))
if 'PSOUDFN
QUIT
Begin DoDot:1
+22 SET UCOUNTED=0
+23 FOR J="YR2004","YR2005","YR2006"
FOR I=1:1:3
SET UCOUNT=$GET(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I))
IF UCOUNT>0
if '$GET(UCOUNTED)
SET UCOUNTED=1
SET PSOUVETS=PSOUVETS+1
SET PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT
End DoDot:1
+24 FOR I=1:1:3
SET PSOUCNT=PSOUCNT+$GET(PSOUCNT("YR2004",I))+$GET(PSOUCNT("YR2005",I))+$GET(PSOUCNT("YR2006",I))
+25 ;
+26 QUIT
+27 ;
CHECK ;check for ICD and IB nodes
+1 ;
+2 NEW PSOREF,PSOIB,PSOOICD,PSOBILLD
+3 SET PSOREF=YY
+4 SET PSOOICD=$PIECE($GET(^PSRX(RXP,"ICD",1,0)),"^",2,8)
+5 ; see if bill already exists
+6 IF PSOREF=0
Begin DoDot:1
+7 IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",2)>0
DO CHKIB^PSOCP1
+8 SET PSOREL=$PIECE($GET(^PSRX(RXP,2)),"^",13)
End DoDot:1
+9 IF PSOREF>0
Begin DoDot:1
+10 IF +$GET(^PSRX(RXP,1,PSOREF,"IB"))
DO CHKIB^PSOCP1
+11 SET PSOREL=$PIECE($GET(^PSRX(RXP,1,YY,0)),"^",18)
End DoDot:1
+12 IF $GET(PSOIB)=1!($GET(PSOIB)=3)
SET PSOBILLD=1
+13 ; if billed/RELEASED and no IBQ node for both sc<50 and nsc
+14 IF $GET(PSOBILLD)&('$DATA(^PSRX(RXP,"IBQ")))
Begin DoDot:1
+15 IF $TRANSLATE(PSOOICD,"^")[1
SET ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$PIECE(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
+16 IF $TRANSLATE(PSOOICD,"^")[0
SET ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$PIECE(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
End DoDot:1
+17 ; find unbilled ones with an ICD node and no IBQ node.
+18 IF '$GET(PSOBILLD)&('$DATA(^PSRX(RXP,"IBQ")))
Begin DoDot:1
+19 if $TRANSLATE(PSOOICD,"^")=""
QUIT
+20 SET ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$PIECE(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
End DoDot:1
+21 IF YY
SET PSOTRF=PSOTRF+1
+22 QUIT
+23 ;
CANCEL ;Cancel erroneous copays/set IBQ node if not there
+1 ;released rx's
+2 NEW PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE
+3 NEW PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB
+4 NEW I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL
+5 SET PSOTYPE="CAN"
+6 SET PSODFN=0
FOR CC=1:1
SET PSODFN=$ORDER(^XTMP(NAMSP,"CANCEL",PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+7 IF CC#100=0
IF $DATA(^XTMP(NAMSP,0,"STOP"))
Begin DoDot:2
+8 SET $PIECE(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT
SET STOP=1
End DoDot:2
QUIT
+9 ; INITIAL ANNUAL CAP FOR 2004 & 2005
SET (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0
+10 FOR RXP=0:0
SET RXP=$ORDER(^XTMP(NAMSP,"CANCEL",PSODFN,RXP))
if 'RXP
QUIT
Begin DoDot:2
+11 SET (SAVCPUN,PSOCPUN)=($PIECE(^PSRX(RXP,0),"^",8)+29)\30
+12 SET YY=""
FOR
SET YY=$ORDER(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))
if YY=""
QUIT
Begin DoDot:3
+13 SET (SAVREF,PSOREF)=YY
+14 ; verify again that it was billed and not already cancelled
+15 SET PSOBILLD=0
+16 IF YY=0
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",2)>0
DO CHKIB^PSOCP1
IF $GET(PSOIB)=1!($GET(PSOIB)=3)
SET PSOBILLD=1
+17 IF YY>0
IF +$PIECE($GET(^PSRX(RXP,1,PSOREF,"IB")),"^")>0
DO CHKIB^PSOCP1
IF $GET(PSOIB)=1!($GET(PSOIB)=3)
SET PSOBILLD=1
+18 if 'PSOBILLD
QUIT
+19 SET PSOREL=$PIECE($GET(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^")
SET PSOFLD=$PIECE($GET(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2)
SET PSOSCP=$PIECE($GET(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3)
+20 SET PSO=3
DO NOW^%DTC
SET PSODT=%
SET PSODA=RXP
SET PSOCOMM="-BKGD CIDC COPAY CANCEL"
SET PSOOLD=""
SET PSONW=""
SET PREA=""
+21 DO CHKACT
+22 SET PSOIB=""
SET PSOIB=$SELECT(PSOREF>0:$GET(^PSRX(RXP,1,YY,"IB")),'PSOREF:$GET(^PSRX(PSODA,"IB")),1:"")
+23 SET (PSOOIBQ,PSOOICD,PSOOIB)=""
+24 SET PSOOICD=$PIECE($GET(^PSRX(RXP,"ICD",1,0)),"^",2,8)
SET PSOOIB=$GET(^PSRX(RXP,"IB"))
SET PSOOIBQ=$GET(^PSRX(RXP,"IBQ"))
+25 IF PSOOIBQ=""&($TRANSLATE(PSOOICD,"^")[0!($TRANSLATE(PSOOICD,"^")[1))
DO SETIBQ
+26 DO SITE
SET PSOCOMM="-BKGD CIDC COPAY CANCEL"
DO RXED^PSOCPA
if PSOOICD[1&($DATA(^PSRX(RXP,"IB")))
SET $PIECE(^PSRX(RXP,"IB"),"^")=""
+27 SET PSOCPUN=SAVCPUN
SET PSOREF=SAVREF
+28 DO ACCUM
End DoDot:3
End DoDot:2
End DoDot:1
if STOP
QUIT
+29 ;
+30 ;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased.
+31 SET PSOTYP="IBQ"
+32 SET PSODFN=0
FOR CC=1:1
SET PSODFN=$ORDER(^XTMP(NAMSP,"NOIBQ",PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+33 IF CC#100=0
IF $DATA(^XTMP(NAMSP,0,"STOP"))
Begin DoDot:2
+34 SET $PIECE(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT
SET STOP=1
End DoDot:2
QUIT
+35 ; INITIAL ANNUAL CAP FOR 2004 & 2005
SET (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0
+36 FOR RXP=0:0
SET RXP=$ORDER(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP))
if 'RXP
QUIT
Begin DoDot:2
+37 SET (SAVCPUN,PSOCPUN)=($PIECE(^PSRX(RXP,0),"^",8)+29)\30
+38 SET YY=""
FOR
SET YY=$ORDER(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY))
if YY=""
QUIT
Begin DoDot:3
+39 SET (SAVREF,PSOREF)=YY
+40 DO SITE
+41 SET PSOREL=$PIECE($GET(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^")
SET PSOFLD=$PIECE($GET(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2)
SET PSOSCP=$PIECE($GET(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3)
+42 SET (PSOOIBQ,PSOOICD,PSOOIB)=""
+43 SET PSOOICD=$PIECE($GET(^PSRX(RXP,"ICD",1,0)),"^",2,8)
SET PSOOIB=$GET(^PSRX(RXP,"IB"))
SET PSOOIBQ=$GET(^PSRX(RXP,"IBQ"))
+44 ;don't want to set again if already did it as part of copay cancel
IF PSOOIBQ=""&($TRANSLATE(PSOOICD,"^")[0!($TRANSLATE(PSOOICD,"^")[1))
DO SETIBQ
Begin DoDot:4
+45 SET I=""
SET IFN=0
FOR I=0:0
SET I=$ORDER(^PSRX(RXP,"A",I))
if 'I
QUIT
SET IFN=I
+46 SET COM=" BKGD CIDC UPDATE"
+47 DO NOW^%DTC
SET IFN=IFN+1
SET ^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN
SET ^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM
+48 KILL DA
+49 if PSOOICD[1&($DATA(^PSRX(RXP,"IB")))
SET $PIECE(^PSRX(RXP,"IB"),"^")=""
End DoDot:4
+50 if '$GET(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))
DO ACCUM
+51 SET PSOCPUN=SAVCPUN
SET PSOREF=SAVREF
End DoDot:3
End DoDot:2
End DoDot:1
if STOP
QUIT
+52 QUIT
+53 ;
CHKACT ;check activity log for prev entry
+1 NEW ZACT,ZPSI,ZACTI
+2 SET ZPSI=0
FOR
SET ZPSI=$ORDER(^PSRX(PSODA,"COPAY",ZPSI))
if ZPSI=""
QUIT
SET ZACTI=""
SET ZACTI=$GET(^PSRX(PSODA,"COPAY",ZPSI,0))
Begin DoDot:1
+3 IF ZACTI["BKGD CIDC COPAY CANCEL"&($PIECE(ZACTI,"^",2)="R")
SET PSOOLD=""
SET PSONW=""
SET PREA="C"
SET ZACT=1
QUIT
End DoDot:1
if $GET(ZACT)
QUIT
+4 IF '$GET(ZACT)
SET PSOOLD="Copay"
SET PSONW="No Copay"
SET PREA="R"
KILL PSOREF
DO ACTLOG^PSOCPA
SET PSOREF=YY
SET PSOOLD=""
SET PSONW=""
SET PREA="C"
+5 QUIT
+6 ;
SETIBQ ; get data from IBQ node, set IBQ node, and 1st piece of IB node
+1 KILL PSOANSQ
+2 NEW PSONIBQ
+3 FOR PSOTYP=1:1:8
Begin DoDot:1
+4 IF PSOTYP=1
SET PSOANSQ("VEH")=$PIECE(PSOOICD,"^",PSOTYP)
+5 IF PSOTYP=2
SET PSOANSQ("RAD")=$PIECE(PSOOICD,"^",PSOTYP)
+6 IF PSOTYP=3
SET PSOANSQ("SC")=$PIECE(PSOOICD,"^",PSOTYP)
+7 IF PSOTYP=4
SET PSOANSQ("PGW")=$PIECE(PSOOICD,"^",PSOTYP)
+8 IF PSOTYP=5
SET PSOANSQ("MST")=$PIECE(PSOOICD,"^",PSOTYP)
+9 IF PSOTYP=6
SET PSOANSQ("HNC")=$PIECE(PSOOICD,"^",PSOTYP)
+10 IF PSOTYP=7
SET PSOANSQ("CV")=$PIECE(PSOOICD,"^",PSOTYP)
+11 IF PSOTYP=8
SET PSOANSQ("SHAD")=$PIECE(PSOOICD,"^",PSOTYP)
End DoDot:1
+12 SET ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV")_"^"_PSOANSQ("SHAD")
+13 QUIT
+14 ;
ACCUM ; ACCUMULATE TOTALS
+1 SET (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)=""
+2 ; get finished, but unreleased totals
+3 IF PSOREL=""
SET PSOYR=$EXTRACT(PSOFLD,1,3)
if PSOYR=""
QUIT
Begin DoDot:1
+4 SET PSOYEAR=$SELECT(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"")
if PSOYEAR=""
QUIT
+5 SET PSOCHRG=7
+6 IF PSOYEAR="YR2006"
SET PSOCHRG=8
+7 SET PSOTOT=$GET(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR))
+8 SET ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
+9 SET ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$GET(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1
+10 SET PSONAM=$PIECE($GET(^DPT(PSODFN,0)),"^")
SET PSONAM=$PIECE(PSONAM,",")
+11 SET PSONAM=$EXTRACT(PSONAM,1,6)
+12 SET ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD
End DoDot:1
SET PSOYEAR=""
QUIT
+13 ;for released ones
+14 SET PSOYR=$EXTRACT(PSOREL,1,3)
+15 if PSOYR'=""
SET PSOYEAR=$SELECT(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"")
+16 if PSOYEAR=""
QUIT
+17 SET PSOCHRG=7
+18 IF PSOYEAR="YR2006"
SET PSOCHRG=8
+19 ;
+20 ;get Xtmp billing amt which would be IBAM tot + any previous refills
+21 SET PSOTOT=$GET(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR))
+22 ;
+23 ;if none yet then init to the IBAM total for the year
+24 IF 'PSOTOT
Begin DoDot:1
+25 FOR PSOSQ=0:0
SET PSOSQ=$ORDER(^IBAM(354.7,PSODFN,1,PSOSQ))
if 'PSOSQ
QUIT
Begin DoDot:2
+26 SET PSOLOG=$GET(^IBAM(354.7,PSODFN,1,PSOSQ,0))
+27 IF $EXTRACT(PSOLOG,1,3)=PSOYR
SET PSOTOT=PSOTOT+$PIECE(PSOLOG,"^",2)
End DoDot:2
End DoDot:1
+28 ;
+29 ;update Xtmp tot nodes with current fill amounts
+30 ; note: cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3
+31 ; routine. Cancelled copays are denoted with an asterisk.
+32 SET ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
+33 SET ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$GET(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1
+34 ;
+35 ;indicate COPAY CANCEL for this fill
+36 ; ;by adding to Xtmp "BILLED"
+37 SET PSONAM=$PIECE($GET(^DPT(PSODFN,0)),"^")
SET PSONAM=$PIECE(PSONAM,",")
+38 SET PSONAM=$EXTRACT(PSONAM,1,6)
+39 SET ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
+40 ;
CAN IF PSOTYPE="CAN"&($GET(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)))
NEW PSOFILL
SET CANCEL=""
SET PSOFILL=YY
DO CHK^PSOCIDC3
IF CANCEL
Begin DoDot:1
+1 SET ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
+2 SET ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$GET(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1
End DoDot:1
+3 QUIT
+4 ;
SITE ; SET UP VARIABLES NEEDED BY BILLING
+1 SET PSOSITE=$SELECT(YY=0:$PIECE(^PSRX(RXP,2),"^",9),1:$PIECE($GET(^PSRX(RXP,1,YY,0)),"^",9))
+2 if PSOSITE=""
QUIT
+3 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
+4 SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
+5 SET PSOSITE7=$PIECE($GET(^PS(59,PSOSITE,"IB")),"^")
+6 QUIT
+7 ;
