- IBEMTBC ;ALB/RLW - IB MEANS TEST BILLING CLOCK FILE UPDATE ; 15-JAN-92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN ; Entry point for Clock Maintenance
- ;
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
- ;S XRTL=$ZU(0),XRTN="IBEMTBC-1" D T0^%ZOSV ;start rt clock
- ;
- D HOME^%ZIS,NOW^%DTC S IBDT=% K % I '$D(DT) D DT^DICRW
- S DIR(0)="PO^2:AEMQZ" D ^DIR K DIR S DFN=+Y I $D(DIRUT) G ENQ
- I $$BILST^DGMTUB(DFN)=0 S J=5 D ERR G EN
- I $D(^IBE(351,"ACT",DFN)) S IBSELECT="ADJUST",IBDR="[IB BILLING CYCLE ADJUST]" D ADJUST,CLEANUP G ENQ
- S IBSELECT="ADD",IBDR="[IB BILLING CYCLE ADD]" D ADDNEW,CLEANUP
- ;
- ENQ I '$D(DIRUT) W ! G EN
- K DIC,IBSELECT,DFN,IBDR,IBEL,DFN,IBIEN,IBDATA,J,DIRUT,IBFAC,IBSITE,IBDT
- ;
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
- ;
- Q
- ;
- ADJUST ; - show current active clock; inactivate and add a new one
- W @IOF
- S IBIEN=$O(^IBE(351,"ACT",DFN,0))
- S DIC="^IBE(351,",DA=IBIEN W !! D EN^DIQ K DIC,DA
- S DIR(0)="Y",DIR("A")="Do you want to update" D ^DIR K DIR Q:+Y<1
- ;
- ; - save current clock, change to cancelled and delete "ACT" xref
- K ^IBE(351,"ACT",DFN) L +(^IBE(351,IBIEN))
- S IBDATA=$P(^IBE(351,IBIEN,0),"^",2,10),$P(^IBE(351,IBIEN,0),"^",4)=3,$P(^(1),"^",3,4)=DUZ_"^"_IBDT
- L -(^IBE(351,IBIEN))
- ;
- ADDNEW ; - add a new clock and allow updating
- I IBSELECT="ADD" D Q:'Y W !
- .W !!,"This patient does not have an active billing clock!"
- .S DIR(0)="Y",DIR("A")="Is it okay to add a new billing clock for this patient"
- .D ^DIR K DIR,DIRUT,DUOUT,DTOUT
- ;
- D SITE^IBAUTL I 'IBSITE S J=1 G ERR
- S I=$P($S($D(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1 I 'I S J=3 G ERR
- K DD,DO,DIC,DR S DIC="^IBE(351,",DIC(0)="L",DLAYGO=351,DIC("DR")=".02////"_DFN_";11////"_DUZ_";12////"_IBDT
- F I=I:1 I I>0,'$D(^IBE(351,I)) L +^IBE(351,I):2 I $T,'$D(^IBE(351,I)) S DINUM=I,X=+IBSITE_I D FILE^DICN K DIC,DR S IBCL=+Y Q:+Y>0
- I IBSELECT'="ADD" S $P(^IBE(351,IBCL,0),"^",2,10)=IBDATA,DIK="^IBE(351,",DA=IBCL D IX1^DIK K DIK
- S DIE="^IBE(351,",DA=IBCL,DR=IBDR D ^DIE K DA,DIE,DR
- L -^IBE(351,IBCL)
- ;
- ; - if the updated clock was cancelled, with no other changes made,
- ; - move the update reason over to the old clock and cancel the new one.
- I IBSELECT'="ADD" D
- .I $L(^IBE(351,+$G(IBIEN),0),"^")=9 S $P(^IBE(351,+$G(IBIEN),0),"^",10)=""
- .I $L(^IBE(351,IBCL,0),"^")=9 S $P(^IBE(351,IBCL,0),"^",10)=""
- .Q:$P(^IBE(351,+$G(IBIEN),0),"^",2,10)'=$P(^IBE(351,IBCL,0),"^",2,10)
- .W !!,"Since you only cancelled the clock, I'll delete the new clock..."
- .I $P(^IBE(351,IBCL,0),"^",11)]"" S $P(^IBE(351,+$G(IBIEN),0),"^",11)=$P(^IBE(351,IBCL,0),"^",11) W !,"(but I'll save the update reason)..."
- .S DA=IBCL,DIK="^IBE(351," D ^DIK K DIK,DA
- ;
- ; - if the user is adding a new clock, and there is no clock
- ; - begin date or status, delete the clock.
- I IBSELECT="ADD" S IBDATA=^IBE(351,IBCL,0) I '$P(IBDATA,"^",3)!'$P(IBDATA,"^",4) D
- .W !!,"This new clock is incomplete!! Deleting the clock from the system..."
- .S DA=IBCL,DIK="^IBE(351," D ^DIK K DIK,DA
- K IBCL
- Q
- ;
- ERR ; - display error messages
- W !?5,$P($T(ERRMSG+J),";;",2)
- CLEANUP K IBCLDA,IBCLDAY,IBCLDT,IBMED,IBCLDOL,X,IBSELECT,DLAYGO,IBDT
- Q
- ;
- ERRMSG ; - possible error messages
- ;;No value returned from call to SITE^IBAUTL
- ;;Record locked, try again later!
- ;;Problem extracting last IFN from zeroth node of CATEGORY C BILLING CLOCK file
- ;;Unable to add record to CATEGORY C BILLING CLOCK file
- ;;Not a Category C patient!
- IBEMTBC ;ALB/RLW - IB MEANS TEST BILLING CLOCK FILE UPDATE ; 15-JAN-92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- EN ; Entry point for Clock Maintenance
- +1 ;
- +2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
- +3 ;S XRTL=$ZU(0),XRTN="IBEMTBC-1" D T0^%ZOSV ;start rt clock
- +4 ;
- +5 DO HOME^%ZIS
- DO NOW^%DTC
- SET IBDT=%
- KILL %
- IF '$DATA(DT)
- DO DT^DICRW
- +6 SET DIR(0)="PO^2:AEMQZ"
- DO ^DIR
- KILL DIR
- SET DFN=+Y
- IF $DATA(DIRUT)
- GOTO ENQ
- +7 IF $$BILST^DGMTUB(DFN)=0
- SET J=5
- DO ERR
- GOTO EN
- +8 IF $DATA(^IBE(351,"ACT",DFN))
- SET IBSELECT="ADJUST"
- SET IBDR="[IB BILLING CYCLE ADJUST]"
- DO ADJUST
- DO CLEANUP
- GOTO ENQ
- +9 SET IBSELECT="ADD"
- SET IBDR="[IB BILLING CYCLE ADD]"
- DO ADDNEW
- DO CLEANUP
- +10 ;
- ENQ IF '$DATA(DIRUT)
- WRITE !
- GOTO EN
- +1 KILL DIC,IBSELECT,DFN,IBDR,IBEL,DFN,IBIEN,IBDATA,J,DIRUT,IBFAC,IBSITE,IBDT
- +2 ;
- +3 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
- +4 ;
- +5 QUIT
- +6 ;
- ADJUST ; - show current active clock; inactivate and add a new one
- +1 WRITE @IOF
- +2 SET IBIEN=$ORDER(^IBE(351,"ACT",DFN,0))
- +3 SET DIC="^IBE(351,"
- SET DA=IBIEN
- WRITE !!
- DO EN^DIQ
- KILL DIC,DA
- +4 SET DIR(0)="Y"
- SET DIR("A")="Do you want to update"
- DO ^DIR
- KILL DIR
- IF +Y<1
- QUIT
- +5 ;
- +6 ; - save current clock, change to cancelled and delete "ACT" xref
- +7 KILL ^IBE(351,"ACT",DFN)
- LOCK +(^IBE(351,IBIEN))
- +8 SET IBDATA=$PIECE(^IBE(351,IBIEN,0),"^",2,10)
- SET $PIECE(^IBE(351,IBIEN,0),"^",4)=3
- SET $PIECE(^(1),"^",3,4)=DUZ_"^"_IBDT
- +9 LOCK -(^IBE(351,IBIEN))
- +10 ;
- ADDNEW ; - add a new clock and allow updating
- +1 IF IBSELECT="ADD"
- Begin DoDot:1
- +2 WRITE !!,"This patient does not have an active billing clock!"
- +3 SET DIR(0)="Y"
- SET DIR("A")="Is it okay to add a new billing clock for this patient"
- +4 DO ^DIR
- KILL DIR,DIRUT,DUOUT,DTOUT
- End DoDot:1
- IF 'Y
- QUIT
- WRITE !
- +5 ;
- +6 DO SITE^IBAUTL
- IF 'IBSITE
- SET J=1
- GOTO ERR
- +7 SET I=$PIECE($SELECT($DATA(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1
- IF 'I
- SET J=3
- GOTO ERR
- +8 KILL DD,DO,DIC,DR
- SET DIC="^IBE(351,"
- SET DIC(0)="L"
- SET DLAYGO=351
- SET DIC("DR")=".02////"_DFN_";11////"_DUZ_";12////"_IBDT
- +9 FOR I=I:1
- IF I>0
- IF '$DATA(^IBE(351,I))
- LOCK +^IBE(351,I):2
- IF $TEST
- IF '$DATA(^IBE(351,I))
- SET DINUM=I
- SET X=+IBSITE_I
- DO FILE^DICN
- KILL DIC,DR
- SET IBCL=+Y
- IF +Y>0
- QUIT
- +10 IF IBSELECT'="ADD"
- SET $PIECE(^IBE(351,IBCL,0),"^",2,10)=IBDATA
- SET DIK="^IBE(351,"
- SET DA=IBCL
- DO IX1^DIK
- KILL DIK
- +11 SET DIE="^IBE(351,"
- SET DA=IBCL
- SET DR=IBDR
- DO ^DIE
- KILL DA,DIE,DR
- +12 LOCK -^IBE(351,IBCL)
- +13 ;
- +14 ; - if the updated clock was cancelled, with no other changes made,
- +15 ; - move the update reason over to the old clock and cancel the new one.
- +16 IF IBSELECT'="ADD"
- Begin DoDot:1
- +17 IF $LENGTH(^IBE(351,+$GET(IBIEN),0),"^")=9
- SET $PIECE(^IBE(351,+$GET(IBIEN),0),"^",10)=""
- +18 IF $LENGTH(^IBE(351,IBCL,0),"^")=9
- SET $PIECE(^IBE(351,IBCL,0),"^",10)=""
- +19 IF $PIECE(^IBE(351,+$GET(IBIEN),0),"^",2,10)'=$PIECE(^IBE(351,IBCL,0),"^",2,10)
- QUIT
- +20 WRITE !!,"Since you only cancelled the clock, I'll delete the new clock..."
- +21 IF $PIECE(^IBE(351,IBCL,0),"^",11)]""
- SET $PIECE(^IBE(351,+$GET(IBIEN),0),"^",11)=$PIECE(^IBE(351,IBCL,0),"^",11)
- WRITE !,"(but I'll save the update reason)..."
- +22 SET DA=IBCL
- SET DIK="^IBE(351,"
- DO ^DIK
- KILL DIK,DA
- End DoDot:1
- +23 ;
- +24 ; - if the user is adding a new clock, and there is no clock
- +25 ; - begin date or status, delete the clock.
- +26 IF IBSELECT="ADD"
- SET IBDATA=^IBE(351,IBCL,0)
- IF '$PIECE(IBDATA,"^",3)!'$PIECE(IBDATA,"^",4)
- Begin DoDot:1
- +27 WRITE !!,"This new clock is incomplete!! Deleting the clock from the system..."
- +28 SET DA=IBCL
- SET DIK="^IBE(351,"
- DO ^DIK
- KILL DIK,DA
- End DoDot:1
- +29 KILL IBCL
- +30 QUIT
- +31 ;
- ERR ; - display error messages
- +1 WRITE !?5,$PIECE($TEXT(ERRMSG+J),";;",2)
- CLEANUP KILL IBCLDA,IBCLDAY,IBCLDT,IBMED,IBCLDOL,X,IBSELECT,DLAYGO,IBDT
- +1 QUIT
- +2 ;
- ERRMSG ; - possible error messages
- +1 ;;No value returned from call to SITE^IBAUTL
- +2 ;;Record locked, try again later!
- +3 ;;Problem extracting last IFN from zeroth node of CATEGORY C BILLING CLOCK file
- +4 ;;Unable to add record to CATEGORY C BILLING CLOCK file
- +5 ;;Not a Category C patient!
