- 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
- ;
- 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 ;
