- IBECEA51 ;ALB/CPM - Cancel/Edit/Add... Update Event Actions ; 05-MAY-93
- ;;Version 2.0 ; INTEGRATED BILLING ;**57**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- CS ; 'Change Status' Entry Action
- N DIE,DA,DR,IBCOMMIT,IBLINE,IBNDX,IBSTAT,IBDEST,IBNBR,IBN
- S IBCOMMIT=0 D EN^VALM2($G(XQORNOD(0))) I '$O(VALMY(0)) G CSQ
- S IBNBR="" F S IBNBR=$O(VALMY(IBNBR)) Q:'IBNBR D
- .S IBLINE=^TMP("IBACME",$J,IBNBR,0),IBNDX=^TMP("IBACMEI",$J,IBNBR)
- .S IBSTAT=$P(IBNDX,"^"),IBN=$P(IBNDX,"^",3)
- .S IBDEST=$S(IBSTAT="OPEN":"CLOSED",1:"OPEN")
- .W !!,"Processing Event #",IBNBR,":"
- .Q:$$FEE(IBN)
- .S DIR(0)="Y",DIR("A")="Change the status of this event from "_IBSTAT_" to "_IBDEST,DIR("?")="^D HCS^IBECEA51"
- .D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) W !,"This event will remain "_IBSTAT_"." Q
- .S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBDEST="OPEN":1,1:2)
- .D ^DIE I $D(Y) W !,"An error occured while changing the status - event is still ",IBSTAT,"." Q
- .S IBCOMMIT=1 W !,"The status has been changed to ",IBDEST,"."
- .S IBLINE=$$SETSTR^VALM1(IBDEST,IBLINE,+$P(VALMDDF("STATUS"),"^",2),+$P(VALMDDF("STATUS"),"^",3))
- .S ^TMP("IBACME",$J,IBNBR,0)=IBLINE,$P(^TMP("IBACMEI",$J,IBNBR),"^",1)=IBDEST
- D PAUSE^VALM1
- CSQ S VALMBCK=$S(IBCOMMIT:"R",1:"")
- Q
- ;
- HCS ; Help for 'Change Status'
- W !!,"Please enter 'Y' or 'YES' to change the status of this event from ",IBSTAT
- W !,"to ",IBDEST,", or 'N', 'NO', or '^' to quit."
- W !!,"If the status of this event is changed to open, and the patient is still an"
- W !,"inpatient in this ward (on the specified admission date), charges will be"
- W !,"billed starting the day after the Date Last Calculated. If the status is"
- W !,"changed to closed, no further charges will be associated with this event."
- Q
- ;
- LC ; 'Last Date Calc' Entry Action
- N IBCOMMIT,IBNBR
- S IBCOMMIT=0 D EN^VALM2($G(XQORNOD(0))) I '$O(VALMY(0)) G LCQ
- S IBNBR="" F S IBNBR=$O(VALMY(IBNBR)) Q:'IBNBR D LCO
- D PAUSE^VALM1
- LCQ S VALMBCK=$S(IBCOMMIT:"R",1:"")
- Q
- ;
- LCO ; Update Last Calc Date for a Single Event.
- N DIE,DR,DA,IBLINE,IBNDX,IBLCAL,IBN,IBEVDT,IBNEWV,%DT
- S IBLINE=^TMP("IBACME",$J,IBNBR,0),IBNDX=^TMP("IBACMEI",$J,IBNBR)
- S IBLCAL=$P(IBNDX,"^",2),IBN=$P(IBNDX,"^",3),IBEVDT=$P(IBNDX,"^",4)
- W !!,"Processing Event #",IBNBR,":"
- I $$FEE(IBN) G LCOQ
- LCP W !,"Date Last Calculated: " W:IBLCAL $$DAT2^IBOUTL(IBLCAL),"// "
- R X:DTIME S:'IBLCAL&(X="") X="^" S:'$T X="^" I $E(X)="^" G LCOQ
- I X="" W " (",$$DAT2^IBOUTL(IBLCAL),")",!,"No change!" G LCOQ
- I $E(X)="?"!($E(X)="@") D HLC G LCP
- S %DT="EPX" D ^%DT I Y<0 D HELP^%DTC G LCP
- I Y<IBEVDT!(Y>$$FMADD^XLFDT(DT,-1)) D HLC G LCP
- S IBNEWV=Y,DIE="^IB(",DA=IBN,DR=".18////"_Y
- D ^DIE I $D(Y) W !,"An error occured while changing the Last Calc Date - no change made!" G LCOQ
- S IBCOMMIT=1 W !,"The Date Last Calculated has been changed to ",$$DAT1^IBOUTL(IBNEWV),"."
- S IBLINE=$$SETSTR^VALM1($$DAT1^IBOUTL(IBNEWV),IBLINE,+$P(VALMDDF("LCALC"),"^",2),+$P(VALMDDF("LCALC"),"^",3))
- S ^TMP("IBACME",$J,IBNBR,0)=IBLINE,$P(^TMP("IBACMEI",$J,IBNBR),"^",2)=IBNEWV
- LCOQ Q
- ;
- HLC ; Help for 'Last Calc Date'
- W !!,"The Date Last Calculated is used to record the last date for which Means Test"
- W !,"charges were billed for an admission."
- W !!,"This date cannot be deleted. Please enter a date not less than the Event"
- W !,"Date (",$$DAT1^IBOUTL(IBEVDT),") and not greater than yesterday (",$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-1)),").",!
- Q
- ;
- ;
- FEE(IBN) ; If the Event Record is for Fee, it is uneditable.
- ; Input: IBN -- Pointer to an event record in file #350
- ; Output: IBFEE -- 1 = record is uneditable
- ; 0 = record is editable
- N IBFEE S IBFEE=0
- I $P($G(^IB(+$G(IBN),0)),"^",8)["FEE" S IBFEE=1 W !,*7,"Fee Admissions cannot be edited!"
- FEEQ Q IBFEE
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEA51 3847 printed Jan 18, 2025@03:22:40 Page 2
- IBECEA51 ;ALB/CPM - Cancel/Edit/Add... Update Event Actions ; 05-MAY-93
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;**57**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- CS ; 'Change Status' Entry Action
- +1 NEW DIE,DA,DR,IBCOMMIT,IBLINE,IBNDX,IBSTAT,IBDEST,IBNBR,IBN
- +2 SET IBCOMMIT=0
- DO EN^VALM2($GET(XQORNOD(0)))
- IF '$ORDER(VALMY(0))
- GOTO CSQ
- +3 SET IBNBR=""
- FOR
- SET IBNBR=$ORDER(VALMY(IBNBR))
- if 'IBNBR
- QUIT
- Begin DoDot:1
- +4 SET IBLINE=^TMP("IBACME",$JOB,IBNBR,0)
- SET IBNDX=^TMP("IBACMEI",$JOB,IBNBR)
- +5 SET IBSTAT=$PIECE(IBNDX,"^")
- SET IBN=$PIECE(IBNDX,"^",3)
- +6 SET IBDEST=$SELECT(IBSTAT="OPEN":"CLOSED",1:"OPEN")
- +7 WRITE !!,"Processing Event #",IBNBR,":"
- +8 if $$FEE(IBN)
- QUIT
- +9 SET DIR(0)="Y"
- SET DIR("A")="Change the status of this event from "_IBSTAT_" to "_IBDEST
- SET DIR("?")="^D HCS^IBECEA51"
- +10 DO ^DIR
- KILL DIR
- IF 'Y!($DATA(DIRUT))!($DATA(DUOUT))
- WRITE !,"This event will remain "_IBSTAT_"."
- QUIT
- +11 SET DIE="^IB("
- SET DA=IBN
- SET DR=".05////"_$SELECT(IBDEST="OPEN":1,1:2)
- +12 DO ^DIE
- IF $DATA(Y)
- WRITE !,"An error occured while changing the status - event is still ",IBSTAT,"."
- QUIT
- +13 SET IBCOMMIT=1
- WRITE !,"The status has been changed to ",IBDEST,"."
- +14 SET IBLINE=$$SETSTR^VALM1(IBDEST,IBLINE,+$PIECE(VALMDDF("STATUS"),"^",2),+$PIECE(VALMDDF("STATUS"),"^",3))
- +15 SET ^TMP("IBACME",$JOB,IBNBR,0)=IBLINE
- SET $PIECE(^TMP("IBACMEI",$JOB,IBNBR),"^",1)=IBDEST
- End DoDot:1
- +16 DO PAUSE^VALM1
- CSQ SET VALMBCK=$SELECT(IBCOMMIT:"R",1:"")
- +1 QUIT
- +2 ;
- HCS ; Help for 'Change Status'
- +1 WRITE !!,"Please enter 'Y' or 'YES' to change the status of this event from ",IBSTAT
- +2 WRITE !,"to ",IBDEST,", or 'N', 'NO', or '^' to quit."
- +3 WRITE !!,"If the status of this event is changed to open, and the patient is still an"
- +4 WRITE !,"inpatient in this ward (on the specified admission date), charges will be"
- +5 WRITE !,"billed starting the day after the Date Last Calculated. If the status is"
- +6 WRITE !,"changed to closed, no further charges will be associated with this event."
- +7 QUIT
- +8 ;
- LC ; 'Last Date Calc' Entry Action
- +1 NEW IBCOMMIT,IBNBR
- +2 SET IBCOMMIT=0
- DO EN^VALM2($GET(XQORNOD(0)))
- IF '$ORDER(VALMY(0))
- GOTO LCQ
- +3 SET IBNBR=""
- FOR
- SET IBNBR=$ORDER(VALMY(IBNBR))
- if 'IBNBR
- QUIT
- DO LCO
- +4 DO PAUSE^VALM1
- LCQ SET VALMBCK=$SELECT(IBCOMMIT:"R",1:"")
- +1 QUIT
- +2 ;
- LCO ; Update Last Calc Date for a Single Event.
- +1 NEW DIE,DR,DA,IBLINE,IBNDX,IBLCAL,IBN,IBEVDT,IBNEWV,%DT
- +2 SET IBLINE=^TMP("IBACME",$JOB,IBNBR,0)
- SET IBNDX=^TMP("IBACMEI",$JOB,IBNBR)
- +3 SET IBLCAL=$PIECE(IBNDX,"^",2)
- SET IBN=$PIECE(IBNDX,"^",3)
- SET IBEVDT=$PIECE(IBNDX,"^",4)
- +4 WRITE !!,"Processing Event #",IBNBR,":"
- +5 IF $$FEE(IBN)
- GOTO LCOQ
- LCP WRITE !,"Date Last Calculated: "
- if IBLCAL
- WRITE $$DAT2^IBOUTL(IBLCAL),"// "
- +1 READ X:DTIME
- if 'IBLCAL&(X="")
- SET X="^"
- if '$TEST
- SET X="^"
- IF $EXTRACT(X)="^"
- GOTO LCOQ
- +2 IF X=""
- WRITE " (",$$DAT2^IBOUTL(IBLCAL),")",!,"No change!"
- GOTO LCOQ
- +3 IF $EXTRACT(X)="?"!($EXTRACT(X)="@")
- DO HLC
- GOTO LCP
- +4 SET %DT="EPX"
- DO ^%DT
- IF Y<0
- DO HELP^%DTC
- GOTO LCP
- +5 IF Y<IBEVDT!(Y>$$FMADD^XLFDT(DT,-1))
- DO HLC
- GOTO LCP
- +6 SET IBNEWV=Y
- SET DIE="^IB("
- SET DA=IBN
- SET DR=".18////"_Y
- +7 DO ^DIE
- IF $DATA(Y)
- WRITE !,"An error occured while changing the Last Calc Date - no change made!"
- GOTO LCOQ
- +8 SET IBCOMMIT=1
- WRITE !,"The Date Last Calculated has been changed to ",$$DAT1^IBOUTL(IBNEWV),"."
- +9 SET IBLINE=$$SETSTR^VALM1($$DAT1^IBOUTL(IBNEWV),IBLINE,+$PIECE(VALMDDF("LCALC"),"^",2),+$PIECE(VALMDDF("LCALC"),"^",3))
- +10 SET ^TMP("IBACME",$JOB,IBNBR,0)=IBLINE
- SET $PIECE(^TMP("IBACMEI",$JOB,IBNBR),"^",2)=IBNEWV
- LCOQ QUIT
- +1 ;
- HLC ; Help for 'Last Calc Date'
- +1 WRITE !!,"The Date Last Calculated is used to record the last date for which Means Test"
- +2 WRITE !,"charges were billed for an admission."
- +3 WRITE !!,"This date cannot be deleted. Please enter a date not less than the Event"
- +4 WRITE !,"Date (",$$DAT1^IBOUTL(IBEVDT),") and not greater than yesterday (",$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-1)),").",!
- +5 QUIT
- +6 ;
- +7 ;
- FEE(IBN) ; If the Event Record is for Fee, it is uneditable.
- +1 ; Input: IBN -- Pointer to an event record in file #350
- +2 ; Output: IBFEE -- 1 = record is uneditable
- +3 ; 0 = record is editable
- +4 NEW IBFEE
- SET IBFEE=0
- +5 IF $PIECE($GET(^IB(+$GET(IBN),0)),"^",8)["FEE"
- SET IBFEE=1
- WRITE !,*7,"Fee Admissions cannot be edited!"
- FEEQ QUIT IBFEE