PSOCPIB ;BHAM ISC/EJW - PHARMACY CO-PAY IB-INITIATED COPAY CHARGE ; 07/27/01
;;7.0;OUTPATIENT PHARMACY;**71,137**;DEC 1997
;External reference to IBARX supported by DBIA 125
; files IB-initiated charges into original or refill node
; IB passes date/time^person initiating copay^Rx#^Fill#^Partial or full charge^IB transaction IEN from file #350
N PSODA,PSOCOMM,PSOREF,PREA,SAVEDUZ,PSORSN
S PREA="I"
S SAVEDUZ=DUZ
S DUZ=$P(Y(1),"^",2)
S PSODA=$P(Y(1),"^",3)
I 'PSODA Q
S PSOREF=$P(Y(1),"^",4)
D CHKIB
S PSOCOMM=$S($P(Y(1),"^",5)="F":"FULL CHARGE",1:"PARTIAL CHARGE")
FILE ; File IB number in ^PSRX
S:PSOREF>0 ^PSRX(PSODA,1,PSOREF,"IB")=$P(Y(1),"^",6) ; Filing in refill node
I PSOREF>0,'$D(^PSRX(PSODA,"IB")) S ^PSRX(PSODA,"IB")="^^" ; If refill "IB" exists, need "IB" entry on original fill node
S:PSOREF=0 $P(^PSRX(PSODA,"IB"),"^",2)=$P(Y(1),"^",6) ;Filing in original fill (zero node)
D ACTLOG^PSOCPA
I $P($G(^PSRX(PSODA,"IB")),"^",1)="" D CANCEL ; IF Rx is 'no copay', send a cancel back to IB in 10 minutes for their IB-initiated charge
S DUZ=SAVEDUZ
Q
;
CANCEL ;
S ZTRTN="CANCHG^PSOCPIB"
S ZTDESC="Call IB back to cancel charges"
S PSORX=Y(1)_"^"_$G(PSOPAR7)
S ZTSAVE("PSORX")=""
S ZTDTH=$$HADD^XLFDT($H,0,0,10),ZTIO=""
D ^%ZTLOAD
Q
;
CANCHG ; Cancel charges if IB initiates a charge for a 'no copay' Rx
N PSODA,PSOCOMM,PSOREF,PREA,SAVEDUZ,X
S PREA="C"
S DUZ=$P(PSORX,"^",2)
S PSODA=$P(PSORX,"^",3)
S PSOREF=$P(PSORX,"^",4)
S PSOPAR7=$P(PSORX,"^",7)
S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
I PSOREF=0 D I $O(X(""))="" Q
. I $P($G(^PSRX(PSODA,"IB")),"^",2)>0 S X(PSODA)=$P(^PSRX(PSODA,"IB"),"^",2)_"^40"
I PSOREF>0 D I $O(X(""))="" Q
. I $P($G(^PSRX(PSODA,1,PSOREF,"IB")),"^",1)>0 S X(PSODA)=$P(^PSRX(PSODA,1,PSOREF,"IB"),"^",1)_"^40"
D CANCEL^IBARX
I $D(Y(PSODA)),+$G(Y(PSODA))'=-1 D
. S $P(^PSRX(PSODA,"IB"),"^",2)=+Y(PSODA),$P(^PSRX(PSODA,"IB"),"^",4)="" K Y(PSODA)
. S PREA="C",PSOREF=0,PSOCOMM="AUTO-CANCEL IB-INITIATED CHARGE FOR 'NO COPAY' RX" D ACTLOG^PSOCPA
F PSOREF=0:0 S PSOREF=$O(Y(PSOREF)) Q:PSOREF="" Q:PSOREF>12 D
. I +Y(PSOREF)'=-1,$D(^PSRX(PSODA,1,PSOREF)) S ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSOREF)
. S PREA="C",PSOCOMM="AUTO-CANCEL IB-INITIATED CHARGE FOR 'NO COPAY' RX" D ACTLOG^PSOCPA
Q
;
CHKIB ; SEE IF IB NUMBER ALREADY EXISTS AND IS A BILL OR UPDATE NUMBER (NOT A CANCEL NUMBER)
N PSOIB,PSOSTAT
I PSOREF=0 S PSOIB=$P($G(^PSRX(PSODA,"IB")),"^",2)
I PSOREF'=0 S PSOIB=$P($G(^PSRX(PSODA,1,PSOREF,"IB")),"^",1)
I PSOIB'="" D STATUS
Q
;
STATUS ;
S PSOSTAT=$$STATUS^IBARX(PSOIB)
I PSOSTAT'=1,PSOSTAT'=3 Q
S PSOCOMM="Copay charge(s) removed"
D ACTLOG^PSOCPA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPIB 2734 printed Sep 23, 2025@20:02:12 Page 2
PSOCPIB ;BHAM ISC/EJW - PHARMACY CO-PAY IB-INITIATED COPAY CHARGE ; 07/27/01
+1 ;;7.0;OUTPATIENT PHARMACY;**71,137**;DEC 1997
+2 ;External reference to IBARX supported by DBIA 125
+3 ; files IB-initiated charges into original or refill node
+4 ; IB passes date/time^person initiating copay^Rx#^Fill#^Partial or full charge^IB transaction IEN from file #350
+5 NEW PSODA,PSOCOMM,PSOREF,PREA,SAVEDUZ,PSORSN
+6 SET PREA="I"
+7 SET SAVEDUZ=DUZ
+8 SET DUZ=$PIECE(Y(1),"^",2)
+9 SET PSODA=$PIECE(Y(1),"^",3)
+10 IF 'PSODA
QUIT
+11 SET PSOREF=$PIECE(Y(1),"^",4)
+12 DO CHKIB
+13 SET PSOCOMM=$SELECT($PIECE(Y(1),"^",5)="F":"FULL CHARGE",1:"PARTIAL CHARGE")
FILE ; File IB number in ^PSRX
+1 ; Filing in refill node
if PSOREF>0
SET ^PSRX(PSODA,1,PSOREF,"IB")=$PIECE(Y(1),"^",6)
+2 ; If refill "IB" exists, need "IB" entry on original fill node
IF PSOREF>0
IF '$DATA(^PSRX(PSODA,"IB"))
SET ^PSRX(PSODA,"IB")="^^"
+3 ;Filing in original fill (zero node)
if PSOREF=0
SET $PIECE(^PSRX(PSODA,"IB"),"^",2)=$PIECE(Y(1),"^",6)
+4 DO ACTLOG^PSOCPA
+5 ; IF Rx is 'no copay', send a cancel back to IB in 10 minutes for their IB-initiated charge
IF $PIECE($GET(^PSRX(PSODA,"IB")),"^",1)=""
DO CANCEL
+6 SET DUZ=SAVEDUZ
+7 QUIT
+8 ;
CANCEL ;
+1 SET ZTRTN="CANCHG^PSOCPIB"
+2 SET ZTDESC="Call IB back to cancel charges"
+3 SET PSORX=Y(1)_"^"_$GET(PSOPAR7)
+4 SET ZTSAVE("PSORX")=""
+5 SET ZTDTH=$$HADD^XLFDT($HOROLOG,0,0,10)
SET ZTIO=""
+6 DO ^%ZTLOAD
+7 QUIT
+8 ;
CANCHG ; Cancel charges if IB initiates a charge for a 'no copay' Rx
+1 NEW PSODA,PSOCOMM,PSOREF,PREA,SAVEDUZ,X
+2 SET PREA="C"
+3 SET DUZ=$PIECE(PSORX,"^",2)
+4 SET PSODA=$PIECE(PSORX,"^",3)
+5 SET PSOREF=$PIECE(PSORX,"^",4)
+6 SET PSOPAR7=$PIECE(PSORX,"^",7)
+7 SET X=PSOPAR7_"^"_+$PIECE(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
+8 IF PSOREF=0
Begin DoDot:1
+9 IF $PIECE($GET(^PSRX(PSODA,"IB")),"^",2)>0
SET X(PSODA)=$PIECE(^PSRX(PSODA,"IB"),"^",2)_"^40"
End DoDot:1
IF $ORDER(X(""))=""
QUIT
+10 IF PSOREF>0
Begin DoDot:1
+11 IF $PIECE($GET(^PSRX(PSODA,1,PSOREF,"IB")),"^",1)>0
SET X(PSODA)=$PIECE(^PSRX(PSODA,1,PSOREF,"IB"),"^",1)_"^40"
End DoDot:1
IF $ORDER(X(""))=""
QUIT
+12 DO CANCEL^IBARX
+13 IF $DATA(Y(PSODA))
IF +$GET(Y(PSODA))'=-1
Begin DoDot:1
+14 SET $PIECE(^PSRX(PSODA,"IB"),"^",2)=+Y(PSODA)
SET $PIECE(^PSRX(PSODA,"IB"),"^",4)=""
KILL Y(PSODA)
+15 SET PREA="C"
SET PSOREF=0
SET PSOCOMM="AUTO-CANCEL IB-INITIATED CHARGE FOR 'NO COPAY' RX"
DO ACTLOG^PSOCPA
End DoDot:1
+16 FOR PSOREF=0:0
SET PSOREF=$ORDER(Y(PSOREF))
if PSOREF=""
QUIT
if PSOREF>12
QUIT
Begin DoDot:1
+17 IF +Y(PSOREF)'=-1
IF $DATA(^PSRX(PSODA,1,PSOREF))
SET ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSOREF)
+18 SET PREA="C"
SET PSOCOMM="AUTO-CANCEL IB-INITIATED CHARGE FOR 'NO COPAY' RX"
DO ACTLOG^PSOCPA
End DoDot:1
+19 QUIT
+20 ;
CHKIB ; SEE IF IB NUMBER ALREADY EXISTS AND IS A BILL OR UPDATE NUMBER (NOT A CANCEL NUMBER)
+1 NEW PSOIB,PSOSTAT
+2 IF PSOREF=0
SET PSOIB=$PIECE($GET(^PSRX(PSODA,"IB")),"^",2)
+3 IF PSOREF'=0
SET PSOIB=$PIECE($GET(^PSRX(PSODA,1,PSOREF,"IB")),"^",1)
+4 IF PSOIB'=""
DO STATUS
+5 QUIT
+6 ;
STATUS ;
+1 SET PSOSTAT=$$STATUS^IBARX(PSOIB)
+2 IF PSOSTAT'=1
IF PSOSTAT'=3
QUIT
+3 SET PSOCOMM="Copay charge(s) removed"
+4 DO ACTLOG^PSOCPA
+5 QUIT
+6 ;
