- 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 Mar 13, 2025@21:06:25 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
