IB20P139 ;ALB/ARH - IB*2*139 POST INIT: ADD OPT COPAY ; 25-OCT-2000
;;2.0;INTEGRATED BILLING;**139**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
COPAY ; Add OPT COPAY for 10/1/2000: $50.8
N IBA,IBX
S IBA(1)="",IBA(2)=" IB*2*139 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
S IBX=$$SETC
I +IBX<0 S IBA(1)=" Error: "_$P(IBX,U,2),IBA(2)="",IBA(3)=" Opt Copay Rate Not Updated!",IBA(4)="",IBA(5)=" Contact Support for assistance."
I +IBX=1 S IBA(1)=" "_$P(IBX,U,2),IBA(2)="",IBA(3)=" Run Option IB MT REL HELD (RATE) CHARGES to release charges."
I (+IBX=0)!(+IBX=2) S IBA(1)=" "_$P(IBX,U,2),IBA(2)="",IBA(3)=" No further action required."
;
D MES^XPDUTL(.IBA)
;
CIQ K IBA S IBA(1)="",IBA(2)=" IB*2*139 Post-Install Complete.",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
Q
;
SETC() ; set Opt Copay
N IBFN,IBCS,IBBS,IBEFDT,IBCHG,DD,DO,DLAYGO,DIC,DIE,DR,DA,X,Y,ZTDTH,ZTRTN,ZTDESC,ZTIO,ZTSK,IBX,IBMSG
S IBMSG="-1^Unknown error!"
;
S IBCS="TL-CAT C OPT COPAY",IBCS=+$O(^IBE(363.1,"B",IBCS,0)) I 'IBCS S IBMSG="-1^TL-CAT C OPT COPAY Charge Set not found!" G SETCQ
S IBBS=+$$MCCRUTL("OUTPATIENT VISIT",5) I 'IBBS S IBMSG="-1^OUTPATIENT VISIT Bedsection not found!" G SETCQ
S IBEFDT=3001001
S IBCHG=50.8
;
S IBX=$O(^IBA(363.2,"AIVDTS"_IBCS,IBBS,-IBEFDT,""))
I +IBX,$P($G(^IBA(363.2,IBX,0)),U,5)'=IBCHG S IBMSG="-1^Opt Copay Charge found with incorrect rate!" G SETCQ
I +IBX S IBMSG="0^Opt Copay Charge already exists on your system." G SETCQ
;
K DD,DO S DLAYGO=363.2,DIC="^IBA(363.2,",DIC(0)="L",X=IBBS_";DGCR(399.1," D FILE^DICN K DIC
I Y<1 K X,Y S IBMSG="-1^Unable to Add Opt Copay to Charge Master!" G SETCQ
S IBFN=+Y
;
S DR=".02////"_IBCS_";.03////"_IBEFDT_";.05////"_IBCHG S DIE="^IBA(363.2,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
S IBMSG="1^Opt Copay updated. "
;
I +$G(XPDQUES("POS QUEUE")) D
. S ZTDTH=$G(XPDQUES("POS QUEUE1")) Q:'ZTDTH
. S ZTRTN="DQ^IBEMTO",ZTDESC="BILLING OF MT OPT CHARGES AWAITING NEW COPAY RATE",ZTIO=""
. D ^%ZTLOAD
. I $D(ZTSK) S IBMSG="2^"_$P(IBMSG,U,2)_"BILLING OF MT OPT CHARGES AWAITING NEW COPAY RATE queued."
. I '$D(ZTSK) S IBMSG=IBMSG_"Unable to queue Release of Charges on Hold task!"
;
SETCQ Q IBMSG
;
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
N IBX,IBY S IBY=""
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
Q IBY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P139 2509 printed Apr 09, 2024@21:28:57 Page 2
IB20P139 ;ALB/ARH - IB*2*139 POST INIT: ADD OPT COPAY ; 25-OCT-2000
+1 ;;2.0;INTEGRATED BILLING;**139**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
COPAY ; Add OPT COPAY for 10/1/2000: $50.8
+1 NEW IBA,IBX
+2 SET IBA(1)=""
SET IBA(2)=" IB*2*139 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ;
+4 SET IBX=$$SETC
+5 IF +IBX<0
SET IBA(1)=" Error: "_$PIECE(IBX,U,2)
SET IBA(2)=""
SET IBA(3)=" Opt Copay Rate Not Updated!"
SET IBA(4)=""
SET IBA(5)=" Contact Support for assistance."
+6 IF +IBX=1
SET IBA(1)=" "_$PIECE(IBX,U,2)
SET IBA(2)=""
SET IBA(3)=" Run Option IB MT REL HELD (RATE) CHARGES to release charges."
+7 IF (+IBX=0)!(+IBX=2)
SET IBA(1)=" "_$PIECE(IBX,U,2)
SET IBA(2)=""
SET IBA(3)=" No further action required."
+8 ;
+9 DO MES^XPDUTL(.IBA)
+10 ;
CIQ KILL IBA
SET IBA(1)=""
SET IBA(2)=" IB*2*139 Post-Install Complete."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+1 QUIT
+2 ;
SETC() ; set Opt Copay
+1 NEW IBFN,IBCS,IBBS,IBEFDT,IBCHG,DD,DO,DLAYGO,DIC,DIE,DR,DA,X,Y,ZTDTH,ZTRTN,ZTDESC,ZTIO,ZTSK,IBX,IBMSG
+2 SET IBMSG="-1^Unknown error!"
+3 ;
+4 SET IBCS="TL-CAT C OPT COPAY"
SET IBCS=+$ORDER(^IBE(363.1,"B",IBCS,0))
IF 'IBCS
SET IBMSG="-1^TL-CAT C OPT COPAY Charge Set not found!"
GOTO SETCQ
+5 SET IBBS=+$$MCCRUTL("OUTPATIENT VISIT",5)
IF 'IBBS
SET IBMSG="-1^OUTPATIENT VISIT Bedsection not found!"
GOTO SETCQ
+6 SET IBEFDT=3001001
+7 SET IBCHG=50.8
+8 ;
+9 SET IBX=$ORDER(^IBA(363.2,"AIVDTS"_IBCS,IBBS,-IBEFDT,""))
+10 IF +IBX
IF $PIECE($GET(^IBA(363.2,IBX,0)),U,5)'=IBCHG
SET IBMSG="-1^Opt Copay Charge found with incorrect rate!"
GOTO SETCQ
+11 IF +IBX
SET IBMSG="0^Opt Copay Charge already exists on your system."
GOTO SETCQ
+12 ;
+13 KILL DD,DO
SET DLAYGO=363.2
SET DIC="^IBA(363.2,"
SET DIC(0)="L"
SET X=IBBS_";DGCR(399.1,"
DO FILE^DICN
KILL DIC
+14 IF Y<1
KILL X,Y
SET IBMSG="-1^Unable to Add Opt Copay to Charge Master!"
GOTO SETCQ
+15 SET IBFN=+Y
+16 ;
+17 SET DR=".02////"_IBCS_";.03////"_IBEFDT_";.05////"_IBCHG
SET DIE="^IBA(363.2,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+18 SET IBMSG="1^Opt Copay updated. "
+19 ;
+20 IF +$GET(XPDQUES("POS QUEUE"))
Begin DoDot:1
+21 SET ZTDTH=$GET(XPDQUES("POS QUEUE1"))
if 'ZTDTH
QUIT
+22 SET ZTRTN="DQ^IBEMTO"
SET ZTDESC="BILLING OF MT OPT CHARGES AWAITING NEW COPAY RATE"
SET ZTIO=""
+23 DO ^%ZTLOAD
+24 IF $DATA(ZTSK)
SET IBMSG="2^"_$PIECE(IBMSG,U,2)_"BILLING OF MT OPT CHARGES AWAITING NEW COPAY RATE queued."
+25 IF '$DATA(ZTSK)
SET IBMSG=IBMSG_"Unable to queue Release of Charges on Hold task!"
End DoDot:1
+26 ;
SETCQ QUIT IBMSG
+1 ;
+2 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+3 QUIT IBY
