IBRREL ;ALB/CPM - RELEASE MEANS TEST CHARGES 'ON HOLD'; Sep 30, 2020@15:16:44
;;2.0;INTEGRATED BILLING;**95,153,199,347,452,651,663,675,677,630,760**;21-MAR-94;Build 25
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; Entry point for stand-alone 'release' option
I '$D(^IB("AH")) W !!,"There are no patients with charges 'on hold' at this time.",! Q
;
D HOME^%ZIS
W !!,"This option is used to release Means Test charges which have been"
W !,"placed 'on hold.' Please enter a patient with charges 'on hold,' and these"
W !,"charges will be displayed and may be selected to be released to Accounts",!,"Receivable.",!
;
ASK ;
R !,"Select PATIENT NAME: ",X:DTIME G END:"^"[$E(X)
I $E(X,1,2)="??" D HLP1 G ASK
I $E(X)="?" D HLP G ASK
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
S DIC="^DPT(",DIC(0)="QME" D ^DIC K DIC G ASK:Y<1 S DFN=+Y
;
K IBA,PRCABN
S IBI=0 F IBNUM=1:1 S IBI=$O(^IB("AH",DFN,IBI)) Q:'IBI S IBA(IBNUM)=IBI
I '$D(IBA) W !!,"This patient does not have any charges 'on hold.'",! G ASK
;
S IBPT=$$PT^IBEFUNC(DFN) W @IOF,$P(IBPT,"^")," Pt ID: ",$P(IBPT,"^",2),! S I="",$P(I,"-",80)="" W I K I
;
RESUME ; - display header and list charges
;
; *** This tag is also called by ECME routine IBNCPDPR ***
; Special variable IBNCPDPR will be set to 1 when called from ECME.
; If this variable is set, then processing in this routine will GOTO tag END and quit rather than go back up
; and ask for another patient.
; Also, special variable IBNCPDPRDEF is the entry# in the list if a specific Rx# was chosen from the ECME screen.
;
;
W !!,"The following IB Actions ",$S($D(PRCABN):"associated with this bill",1:"for this patient")," are ON HOLD:"
D HDR
;
; display the list of IB charges on hold
S IBQ=0 F IBNUM=1:1 Q:'$D(IBA(IBNUM))!IBQ D Q:IBQ
. I $Y+5>IOSL D PAUSE^VALM1 S:$D(DIRUT) IBQ=1 Q:IBQ S $Y=0 D HDR
. S IBN=IBA(IBNUM) D LST
. Q
;
; - prompt user to select IB Actions
S DIR(0)="LA^1:"_(IBNUM-1)_"^K:X[""."" X"
S DIR("A")="Select IB Action"_$E("s",IBNUM>2)_" (REF #) to release (or '^' to exit): "
I $G(IBNCPDPRDEF) S DIR("B")=IBNCPDPRDEF ; default value if coming in from ECME
S DIR("?")="^D HELP^IBRREL"
W ! D ^DIR K DIR
I $D(DIRUT)!($D(DUOUT)) G END:($D(PRCABN)!$G(IBNCPDPR)) D END W ! G ASK
;
S IBRANGE=Y,IBSEQNO=1,IBDUZ=DUZ
; IB*2.0*630 - Check for duplicate copays
N IBDUPCPY,IBCNTR,IBIEN,IBIENS
S IBIENS="",IBDUPCPY=0
F IBCNTR=1:1 S IBIEN=$P(Y,",",IBCNTR) Q:'IBIEN S IBIENS=$G(IBA(IBIEN)) Q:'IBIENS D Q:IBDUPCPY
. S IBDUPCPY=$$DUPCPYCHK^IBECEA1(IBIENS)
. ; If duplicate copay, display message
. I IBDUPCPY D CPYDISPLAY^IBECEA1(IBIENS,IBDUPCPY)
. Q
; Send user back to selection prompt if duplicate copays exist
Q:IBDUPCPY
; End of IB*2.0*630 changes
;
S DIR(0)="Y",DIR("A")="OK to pass "_$S($P(Y,",",2):"these charges",1:"this charge")_" to Accounts Receivable"
D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) G END:($D(PRCABN)!$G(IBNCPDPR)) D END W ! G ASK
;
; - pass charges to Accounts Receivable
W !!,"Passing charges to Accounts Receivable...",! D HDR
F IBCTR=1:1 S IBNUM=$P(IBRANGE,",",IBCTR) Q:'IBNUM I $D(IBA(IBNUM)) S IBNOS=IBA(IBNUM) D ^IBR,ERR:Y<1 I Y>0 S IBN=IBA(IBNUM) D UPDUCDB(IBN),UPDMH(IBN),LST ; IB*2.0*760
W !!,"The charge"_$E("s",$P(IBRANGE,",",2)>0)_" listed above "_$S($P(IBRANGE,",",2):"have",1:"has")_" been passed to Accounts Receivable.",!
;
I $G(IBNCPDPR) W !! S DIR(0)="E" D ^DIR K DIR G END ; exit for ECME
;
I '$D(PRCABN) W !! S DIR(0)="E" D ^DIR K DIR D END W ! G ASK
;
END K DIC,DIRUT,DUOUT,DTOUT,IBA,IBAFY,IBARTYP,IBATYP,IBCTR,IBN,IBDA,IBDUZ
K IBFAC,IBI,IBIL,IBRANGE,IBNOS,IBNUM,IBPT,IBQ,IBSEQNO,IBSERV,IBSITE
K IBTOTL,IBTRAN,IBWHER,VA,VAERR,VADM
K:'$D(PRCABN) DFN
Q
;
;
HDR ; Display charge header.
N IBLINE S $P(IBLINE,"=",81)=""
W !,IBLINE,!," REF Action ID Bill Type",?42,"Bill #",?51,"Fr/Fl Dt",?61,"To/Rls Dt",?73,"Charge"
W !,IBLINE Q
;
LST ; Display individual IB Action.
N IBND,IBND1,IBRXN,IBRX,IBRF,IBRDT,IENS,IBECME
S IBND=$G(^IB(IBN,0)),IBND1=$G(^IB(IBN,1)),(IBRXN,IBRX,IBRF,IBRDT,IBECME)=0
I $P(IBND,"^",4)["52:" D
. S IBRXN=+$P($P(IBND,"^",4),":",2) ; Rx ien
. S IBRX=$P($P(IBND,"^",8),"-") ; external Rx#
. S IBRF=+$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill
. S IBECME=$P($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6) ; ecme# DBIA# 4719
. I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01)
. I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22)
. Q
;
W !?1,$J(IBNUM,2),?6,$J(+IBND,9)
W ?19,$S(IBRXN>0:"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),1:$P(IBND,"^",8)) ;IB*2.0*651
W ?42,$P($P(IBND,"^",11),"-",2)
W ?51,$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",14)))
W ?61,$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":($P(IBND,"^",15)),1:$P(IBND1,"^",2)))
W ?70,$J(+$P(IBND,"^",7),9,2)
I IBECME W !?19,"ECME #: ",IBECME
Q
;
ERR ; Display error message.
W !?1,$J(IBNUM,2),?7,"Error encountered - a separate bulletin has been posted"
Q
;
HLP ; Display basic help message.
W !!,"Enter: the name of a patient with charges 'on hold,' or"
W !?10,"'??' -- to see all patients with charges 'on hold,' or"
W !?10,"'^' -- to quit this option.",!
Q
;
HLP1 ; Display all patients with charges 'on hold.'
N DFN,I,IBQ,PID
W !!,"The following patients have charges 'on hold:'"
S (DFN,IBQ)=0 F I=1:1 S DFN=$O(^IB("AH",DFN)) Q:'DFN D:'(I#15) Q:IBQ S PID=$$PT^IBEFUNC(DFN) W !?3,$P(PID,"^"),$J("",10),$P(PID,"^",2)
. R !,"Enter RETURN to continue or '^' to stop: ",X:DTIME S:X["^"!('$T) IBQ=1 Q
W ! Q
;
HELP ; Help for the 'Select' prompt.
W !!?4,"Please enter a list or range of IB Actions (i.e. 1,3,5 or 2-4,8), none"
W !?4,"greater than ",IBNUM-1,", to be passed to Accounts Receivable, or '^' to quit."
Q
;
AR ; Accounts Receivable entry point to release charges.
; Input: PRCABN -- ien of Bill/Accounts Receivable
Q:$D(PRCABN)[0 Q:'$$IB^IBRUTL(PRCABN,1) G RESUME
;
;Start - IB*2.0*663
UPDUCDB(IBN) ;Update the Visit Tracking DB with the bill Number
N IBND,IBVSTIEN
Q:IBN=""
S IBND=$G(^IB(IBN,0))
;IB*2.0*663 If charge successfully passed, extract the bill number and update the visit tracking database if this is a CC URGENT CARE Charge
I $P(IBND,U,11)'="",$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^")["CC URGENT CARE" D
. ; send update to the Visit Tracking file.
. S IBVSTIEN=$$FNDVST^IBECEA4("ON HOLD",$P(IBND,U,14),$P(IBND,U,2))
. ;ADD THE NOT FOUND MESSAGE HERE?
. D:+IBVSTIEN UPDATE^IBECEA38(IBVSTIEN,2,$P(IBND,U,11),"",1,.IBERROR)
Q
;End IB*2.0*663
UPDMH(IBN) ; update MH Visit tracking DB IB*2.0*760
N IBATYPE,IBBLNO,IBCDCHK,IBERROR,IBFR,IBMHVST,IBND,IBSTOPDA,Z
I +$G(IBN)'>0 Q
S IBND=^IB(IBN,0)
S IBSTOPDA=$P(IBND,U,20),IBCDCHK=0,IBATYPE=+$P(IBND,U,3),IBFR=+$P(IBND,U,14),IBBLNO=$P(IBND,U,11)
I $P($G(^IBE(350.1,IBATYPE,0)),U)["CC MH" S IBCDCHK=1
I 'IBCDCHK,$$CDCHK^IBECEAMH($$GET1^DIQ(352.5,IBSTOPDA_",",.01,"E"),IBFR) S IBCDCHK=1
I IBBLNO'="",IBCDCHK D
.S IBMHVST=$O(^IBMH(351.83,"D",IBN,"")) Q:'IBMHVST
.D MESS2B^IBECEAMH S Z=$$UPDATE^IBECEAMH(0,IBMHVST,2,IBBLNO,"",1,.IBERROR)
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRREL 7237 printed Oct 16, 2024@18:27:35 Page 2
IBRREL ;ALB/CPM - RELEASE MEANS TEST CHARGES 'ON HOLD'; Sep 30, 2020@15:16:44
+1 ;;2.0;INTEGRATED BILLING;**95,153,199,347,452,651,663,675,677,630,760**;21-MAR-94;Build 25
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; Entry point for stand-alone 'release' option
+1 IF '$DATA(^IB("AH"))
WRITE !!,"There are no patients with charges 'on hold' at this time.",!
QUIT
+2 ;
+3 DO HOME^%ZIS
+4 WRITE !!,"This option is used to release Means Test charges which have been"
+5 WRITE !,"placed 'on hold.' Please enter a patient with charges 'on hold,' and these"
+6 WRITE !,"charges will be displayed and may be selected to be released to Accounts",!,"Receivable.",!
+7 ;
ASK ;
+1 READ !,"Select PATIENT NAME: ",X:DTIME
if "^"[$EXTRACT(X)
GOTO END
+2 IF $EXTRACT(X,1,2)="??"
DO HLP1
GOTO ASK
+3 IF $EXTRACT(X)="?"
DO HLP
GOTO ASK
+4 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+5 SET DIC="^DPT("
SET DIC(0)="QME"
DO ^DIC
KILL DIC
if Y<1
GOTO ASK
SET DFN=+Y
+6 ;
+7 KILL IBA,PRCABN
+8 SET IBI=0
FOR IBNUM=1:1
SET IBI=$ORDER(^IB("AH",DFN,IBI))
if 'IBI
QUIT
SET IBA(IBNUM)=IBI
+9 IF '$DATA(IBA)
WRITE !!,"This patient does not have any charges 'on hold.'",!
GOTO ASK
+10 ;
+11 SET IBPT=$$PT^IBEFUNC(DFN)
WRITE @IOF,$PIECE(IBPT,"^")," Pt ID: ",$PIECE(IBPT,"^",2),!
SET I=""
SET $PIECE(I,"-",80)=""
WRITE I
KILL I
+12 ;
RESUME ; - display header and list charges
+1 ;
+2 ; *** This tag is also called by ECME routine IBNCPDPR ***
+3 ; Special variable IBNCPDPR will be set to 1 when called from ECME.
+4 ; If this variable is set, then processing in this routine will GOTO tag END and quit rather than go back up
+5 ; and ask for another patient.
+6 ; Also, special variable IBNCPDPRDEF is the entry# in the list if a specific Rx# was chosen from the ECME screen.
+7 ;
+8 ;
+9 WRITE !!,"The following IB Actions ",$SELECT($DATA(PRCABN):"associated with this bill",1:"for this patient")," are ON HOLD:"
+10 DO HDR
+11 ;
+12 ; display the list of IB charges on hold
+13 SET IBQ=0
FOR IBNUM=1:1
if '$DATA(IBA(IBNUM))!IBQ
QUIT
Begin DoDot:1
+14 IF $Y+5>IOSL
DO PAUSE^VALM1
if $DATA(DIRUT)
SET IBQ=1
if IBQ
QUIT
SET $Y=0
DO HDR
+15 SET IBN=IBA(IBNUM)
DO LST
+16 QUIT
End DoDot:1
if IBQ
QUIT
+17 ;
+18 ; - prompt user to select IB Actions
+19 SET DIR(0)="LA^1:"_(IBNUM-1)_"^K:X[""."" X"
+20 SET DIR("A")="Select IB Action"_$EXTRACT("s",IBNUM>2)_" (REF #) to release (or '^' to exit): "
+21 ; default value if coming in from ECME
IF $GET(IBNCPDPRDEF)
SET DIR("B")=IBNCPDPRDEF
+22 SET DIR("?")="^D HELP^IBRREL"
+23 WRITE !
DO ^DIR
KILL DIR
+24 IF $DATA(DIRUT)!($DATA(DUOUT))
if ($DATA(PRCABN)!$GET(IBNCPDPR))
GOTO END
DO END
WRITE !
GOTO ASK
+25 ;
+26 SET IBRANGE=Y
SET IBSEQNO=1
SET IBDUZ=DUZ
+27 ; IB*2.0*630 - Check for duplicate copays
+28 NEW IBDUPCPY,IBCNTR,IBIEN,IBIENS
+29 SET IBIENS=""
SET IBDUPCPY=0
+30 FOR IBCNTR=1:1
SET IBIEN=$PIECE(Y,",",IBCNTR)
if 'IBIEN
QUIT
SET IBIENS=$GET(IBA(IBIEN))
if 'IBIENS
QUIT
Begin DoDot:1
+31 SET IBDUPCPY=$$DUPCPYCHK^IBECEA1(IBIENS)
+32 ; If duplicate copay, display message
+33 IF IBDUPCPY
DO CPYDISPLAY^IBECEA1(IBIENS,IBDUPCPY)
+34 QUIT
End DoDot:1
if IBDUPCPY
QUIT
+35 ; Send user back to selection prompt if duplicate copays exist
+36 if IBDUPCPY
QUIT
+37 ; End of IB*2.0*630 changes
+38 ;
+39 SET DIR(0)="Y"
SET DIR("A")="OK to pass "_$SELECT($PIECE(Y,",",2):"these charges",1:"this charge")_" to Accounts Receivable"
+40 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))!($DATA(DUOUT))
if ($DATA(PRCABN)!$GET(IBNCPDPR))
GOTO END
DO END
WRITE !
GOTO ASK
+41 ;
+42 ; - pass charges to Accounts Receivable
+43 WRITE !!,"Passing charges to Accounts Receivable...",!
DO HDR
+44 ; IB*2.0*760
FOR IBCTR=1:1
SET IBNUM=$PIECE(IBRANGE,",",IBCTR)
if 'IBNUM
QUIT
IF $DATA(IBA(IBNUM))
SET IBNOS=IBA(IBNUM)
DO ^IBR
if Y<1
DO ERR
IF Y>0
SET IBN=IBA(IBNUM)
DO UPDUCDB(IBN)
DO UPDMH(IBN)
DO LST
+45 WRITE !!,"The charge"_$EXTRACT("s",$PIECE(IBRANGE,",",2)>0)_" listed above "_$SELECT($PIECE(IBRANGE,",",2):"have",1:"has")_" been passed to Accounts Receivable.",!
+46 ;
+47 ; exit for ECME
IF $GET(IBNCPDPR)
WRITE !!
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO END
+48 ;
+49 IF '$DATA(PRCABN)
WRITE !!
SET DIR(0)="E"
DO ^DIR
KILL DIR
DO END
WRITE !
GOTO ASK
+50 ;
END KILL DIC,DIRUT,DUOUT,DTOUT,IBA,IBAFY,IBARTYP,IBATYP,IBCTR,IBN,IBDA,IBDUZ
+1 KILL IBFAC,IBI,IBIL,IBRANGE,IBNOS,IBNUM,IBPT,IBQ,IBSEQNO,IBSERV,IBSITE
+2 KILL IBTOTL,IBTRAN,IBWHER,VA,VAERR,VADM
+3 if '$DATA(PRCABN)
KILL DFN
+4 QUIT
+5 ;
+6 ;
HDR ; Display charge header.
+1 NEW IBLINE
SET $PIECE(IBLINE,"=",81)=""
+2 WRITE !,IBLINE,!," REF Action ID Bill Type",?42,"Bill #",?51,"Fr/Fl Dt",?61,"To/Rls Dt",?73,"Charge"
+3 WRITE !,IBLINE
QUIT
+4 ;
LST ; Display individual IB Action.
+1 NEW IBND,IBND1,IBRXN,IBRX,IBRF,IBRDT,IENS,IBECME
+2 SET IBND=$GET(^IB(IBN,0))
SET IBND1=$GET(^IB(IBN,1))
SET (IBRXN,IBRX,IBRF,IBRDT,IBECME)=0
+3 IF $PIECE(IBND,"^",4)["52:"
Begin DoDot:1
+4 ; Rx ien
SET IBRXN=+$PIECE($PIECE(IBND,"^",4),":",2)
+5 ; external Rx#
SET IBRX=$PIECE($PIECE(IBND,"^",8),"-")
+6 ; fill# or 0 for original fill
SET IBRF=+$PIECE($PIECE(IBND,"^",4),":",3)
+7 ; ecme# DBIA# 4719
SET IBECME=$PIECE($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6)
+8 IF IBRF
SET IENS=+IBRF
SET IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01)
+9 IF 'IBRF
SET IENS=+IBRXN
SET IBRDT=$$FILE^IBRXUTL(+IENS,22)
+10 QUIT
End DoDot:1
+11 ;
+12 WRITE !?1,$JUSTIFY(IBNUM,2),?6,$JUSTIFY(+IBND,9)
+13 ;IB*2.0*651
WRITE ?19,$SELECT(IBRXN>0:"Rx #: "_IBRX_$SELECT(IBRF>0:"("_IBRF_")",1:""),1:$PIECE(IBND,"^",8))
+14 WRITE ?42,$PIECE($PIECE(IBND,"^",11),"-",2)
+15 WRITE ?51,$$DAT1^IBOUTL($SELECT(IBRXN>0:IBRDT,1:$PIECE(IBND,"^",14)))
+16 WRITE ?61,$$DAT1^IBOUTL($SELECT($PIECE(IBND,"^",15)'="":($PIECE(IBND,"^",15)),1:$PIECE(IBND1,"^",2)))
+17 WRITE ?70,$JUSTIFY(+$PIECE(IBND,"^",7),9,2)
+18 IF IBECME
WRITE !?19,"ECME #: ",IBECME
+19 QUIT
+20 ;
ERR ; Display error message.
+1 WRITE !?1,$JUSTIFY(IBNUM,2),?7,"Error encountered - a separate bulletin has been posted"
+2 QUIT
+3 ;
HLP ; Display basic help message.
+1 WRITE !!,"Enter: the name of a patient with charges 'on hold,' or"
+2 WRITE !?10,"'??' -- to see all patients with charges 'on hold,' or"
+3 WRITE !?10,"'^' -- to quit this option.",!
+4 QUIT
+5 ;
HLP1 ; Display all patients with charges 'on hold.'
+1 NEW DFN,I,IBQ,PID
+2 WRITE !!,"The following patients have charges 'on hold:'"
+3 SET (DFN,IBQ)=0
FOR I=1:1
SET DFN=$ORDER(^IB("AH",DFN))
if 'DFN
QUIT
if '(I#15)
Begin DoDot:1
+4 READ !,"Enter RETURN to continue or '^' to stop: ",X:DTIME
if X["^"!('$TEST)
SET IBQ=1
QUIT
End DoDot:1
if IBQ
QUIT
SET PID=$$PT^IBEFUNC(DFN)
WRITE !?3,$PIECE(PID,"^"),$JUSTIFY("",10),$PIECE(PID,"^",2)
+5 WRITE !
QUIT
+6 ;
HELP ; Help for the 'Select' prompt.
+1 WRITE !!?4,"Please enter a list or range of IB Actions (i.e. 1,3,5 or 2-4,8), none"
+2 WRITE !?4,"greater than ",IBNUM-1,", to be passed to Accounts Receivable, or '^' to quit."
+3 QUIT
+4 ;
AR ; Accounts Receivable entry point to release charges.
+1 ; Input: PRCABN -- ien of Bill/Accounts Receivable
+2 if $DATA(PRCABN)[0
QUIT
if '$$IB^IBRUTL(PRCABN,1)
QUIT
GOTO RESUME
+3 ;
+4 ;Start - IB*2.0*663
UPDUCDB(IBN) ;Update the Visit Tracking DB with the bill Number
+1 NEW IBND,IBVSTIEN
+2 if IBN=""
QUIT
+3 SET IBND=$GET(^IB(IBN,0))
+4 ;IB*2.0*663 If charge successfully passed, extract the bill number and update the visit tracking database if this is a CC URGENT CARE Charge
+5 IF $PIECE(IBND,U,11)'=""
IF $PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")["CC URGENT CARE"
Begin DoDot:1
+6 ; send update to the Visit Tracking file.
+7 SET IBVSTIEN=$$FNDVST^IBECEA4("ON HOLD",$PIECE(IBND,U,14),$PIECE(IBND,U,2))
+8 ;ADD THE NOT FOUND MESSAGE HERE?
+9 if +IBVSTIEN
DO UPDATE^IBECEA38(IBVSTIEN,2,$PIECE(IBND,U,11),"",1,.IBERROR)
End DoDot:1
+10 QUIT
+11 ;End IB*2.0*663
UPDMH(IBN) ; update MH Visit tracking DB IB*2.0*760
+1 NEW IBATYPE,IBBLNO,IBCDCHK,IBERROR,IBFR,IBMHVST,IBND,IBSTOPDA,Z
+2 IF +$GET(IBN)'>0
QUIT
+3 SET IBND=^IB(IBN,0)
+4 SET IBSTOPDA=$PIECE(IBND,U,20)
SET IBCDCHK=0
SET IBATYPE=+$PIECE(IBND,U,3)
SET IBFR=+$PIECE(IBND,U,14)
SET IBBLNO=$PIECE(IBND,U,11)
+5 IF $PIECE($GET(^IBE(350.1,IBATYPE,0)),U)["CC MH"
SET IBCDCHK=1
+6 IF 'IBCDCHK
IF $$CDCHK^IBECEAMH($$GET1^DIQ(352.5,IBSTOPDA_",",.01,"E"),IBFR)
SET IBCDCHK=1
+7 IF IBBLNO'=""
IF IBCDCHK
Begin DoDot:1
+8 SET IBMHVST=$ORDER(^IBMH(351.83,"D",IBN,""))
if 'IBMHVST
QUIT
+9 DO MESS2B^IBECEAMH
SET Z=$$UPDATE^IBECEAMH(0,IBMHVST,2,IBBLNO,"",1,.IBERROR)
+10 QUIT
End DoDot:1
+11 QUIT
