IBTRE2 ;ALB/AAS - CLAIMS TRACKING - ACTIONS ;27-JUN-93
;;2.0;INTEGRATED BILLING;**23,121,249,312,568**;21-MAR-94;Build 40
;;Per VA Directive 6402, this routine should not be modified.
;
% G EN^IBTRE
;
AT ; -- Add tracking entry
I '$$PFSSWARN^IBBSHDWN() S VALMBCK="R" Q ;IB*2.0*312
D FULL^VALM1
N X,Y,DIC,DA,DR,DD,DO,DIR,DIRUT,DTOUT,DUOUT,IBETYP,IBQUIT,IBTDT,VAIN,VAINDT,IBTRN,IBTDTE
N IBDEL,IBDELO,IBMARK,IBPR,IBPRO,PCOV,PIEN,RC
;
TEST S IBQUIT=0
S DIC(0)="AEQMNZ",DIC="^IBE(356.6,",DIC("S")="I $P(^(0),U,3)<3!($P(^(0),U,3)=4)",DIC("A")="Select Tracking Type: " ;568
D ^DIC K DIC S IBETYP=+Y I +Y<0 G ATQ
W !
;
ADM I IBETYP=$O(^IBE(356.6,"AC",1,0)) D I IBQUIT G ATQ
.N DIR
.S DIR("?")=" "
.S DIR("?",1)=" Enter any Date!"
.S DIR("?",2)=" "
.S DIR("?",3)=" If the patient was an inpatient on that date the system will use the"
.S DIR("?",4)=" correct admission date. If you are tracking an admissions at another"
.S DIR("?",5)=" facility you may enter that date. Enter '??' to get a list of the"
.S DIR("?",6)=" last 10 admissions for this patient."
.S DIR("??")="^D LISTA^IBTRE20"
.S DIR(0)="DO^::AEXTP",DIR("A")="Admission Date"
.D ^DIR K DIR S (IBTDT,VAINDT)=+Y I $P(VAINDT,".",2)="" S VAINDT=VAINDT+.24
.I $D(DIRUT)!($P(IBTDT,".")'?7N) S IBQUIT=1 Q
.; -- check for valid admission
.S VA200="" D INP^VADPT I VAIN(1)="" D ;look for one day admission
..S IBX=+$O(^(+$O(^DGPM("ATID1",DFN,9999999-IBTDT)),0)),IBX=+$G(^DGPM(IBX,0))
..I $E(IBX,1,7)=IBTDT S VAINDT=IBX D INP^VADPT ;9999999.9999999
..I VAIN(1) W !!,"WARNING: This appears to be a one day stay."
.I VAIN(1)="" D
..W !!,*7,"WARNING: Patient does not appear to be an inpatient on this date!",!
..I VAIN(7)="" S VAIN(7)=IBTDT,Y=IBTDT D D^DIQ S $P(VAIN(7),"^",2)=Y
.;
.S DIR("?")="No admission was found for this date, enter 'Yes' if you want to add this anyway, or 'No' if you do not wish to track this date."
.S DIR(0)="Y",DIR("A")="Okay to Add Claims Tracking entry for Admission Date "_$P(VAIN(7),"^",2),DIR("B")="NO"
.D ^DIR K DIR I $D(DIRUT)!('Y) S IBQUIT=1 Q
.I VAIN(1) D ADM^IBTUTL(VAIN(1))
.I 'VAIN(1) D OTH^IBTUTL(DFN,IBETYP,IBTDT)
.Q
;
OPT I IBETYP=$O(^IBE(356.6,"AC",2,0)) D I IBQUIT G ATQ
.;
.N DIR,IBSD,IBARRAY
.;get all possible scheduling data for patient
.K ^TMP($J,"SDAMA301")
.S IBARRAY(4)=DFN,IBARRAY("SORT")="P",IBARRAY("FLDS")="1;2;3;10;12",IBSD=$$SDAPI^SDAMA301(.IBARRAY)
.;
.S DIR("?")="Time is Required."
.S DIR("?",1)=" Enter the Outpatient Visit Date."
.S DIR("?",2)=" If no scheduled visit is found you will be given a warning. Enter"
.S DIR("?",3)=" '??' to get a list of scheduled visits between "_$$DAT1^IBOUTL(IBTBDT)_" and "_$$DAT1^IBOUTL(IBTEDT)_"."
.I '$D(IBTASS) S DIR("?",4)=" Use the change date range action to change listing of scheduled Visits."
.S DIR("??")="^D LISTO^IBTRE20"
.S DIR(0)="DO^::AEXTP",DIR("A")="Outpatient Visit Date"
.D ^DIR K DIR S IBTDT=Y
.I $D(DIRUT)!($P(IBTDT,".")'?7N) S IBQUIT=1 Q
.;
.; check scheduling and encounters file for entries
.S X=$D(^TMP($J,"SDAMA301",DFN,IBTDT))
.;
.I 'X,IBSD<0 W !!,*7,"WARNING: Unable to look up Visit information for this Patient" X "N IBX S IBX=0 F S IBX=$O(^TMP($J,""SDAMA301"",IBX)) W !?5,IBX,?10,$G(^(IBX))"
.;
.I 'X,IBSD S Y=$O(^TMP($J,"SDAMA301",DFN,$P(IBTDT,"."))) I $P(IBTDT,".")=$P(Y,".") S IBTDT=Y,X=1
.;
.; if non say so
.I 'X,IBSD'=-1 W !!,*7,"WARNING: No Visit information for this Patient for this date.",!
.;
.; ask if okay to add entry.
.S Y=IBTDT D D^DIQ S IBTDTE=Y
.S DIR(0)="Y",DIR("A")="Okay to Add Claims Tracking entry for Visit Date "_IBTDTE,DIR("B")="NO"
.D ^DIR K DIR I $D(DIRUT)!('Y) S IBQUIT=1 Q
.D OPT^IBTUTL1(DFN,IBETYP,IBTDT,$P($G(^TMP($J,"SDAMA301",DFN,IBTDT)),"^",12))
.K ^TMP($J,"SDAMA301")
.Q
;
SCH I IBETYP=$O(^IBE(356.6,"AC",5,0)) D I IBQUIT G ATQ
.N DIR
.S DIR("?")=" "
.S DIR("?",1)=" Enter date of the scheduled admission."
.S DIR("?",2)=" If you use the scheduled admission package to schedule admissions"
.S DIR("?",3)=" you may enter '??' to get a list of scheduled admissions between"
.S DIR("?",4)=" "_$$DAT1^IBOUTL(IBTBDT)_" and "_$$DAT1^IBOUTL(IBTEDT)_". Use the change date range action"
.S DIR("?",5)=" to change listing of scheduled admissions."
.S DIR("?",5)=" This should be a future scheduled admission."
.S DIR(0)="DO^::AEXT",DIR("A")="Scheduled Admission Date"
.S DIR("??")="^D LISTS^IBTRE20"
.D ^DIR K DIR S IBTDT=+Y
.I $D(DIRUT)!($P(IBTDT,".")'?7N) S IBQUIT=1 Q
.; ask if okay to add entry.
.D FINDS^IBTRE20
.S Y=IBTDT D D^DIQ S IBTDTE=Y
.S DIR(0)="Y",DIR("A")="Okay to Add Claims Tracking entry for Scheduled Adm. Date "_IBTDTE,DIR("B")="NO"
.D ^DIR K DIR I $D(DIRUT)!('Y) S IBQUIT=1 Q
.I IBTDT\1'>DT S VAINDT=IBTDT\1+.24 D INP^VADPT I $G(VAIN(1)) D Q
..W !!,"Patient an inpatient on this date, using inpatient admission."
..D ADM^IBTUTL(VAIN(1))
.D SCH^IBTUTL2(DFN,IBTDT)
.Q
;
PRO I IBETYP=$O(^IBE(356.6,"AC",3,0)) D I IBQUIT G ATQ
.;
.N DIR,IBSD,IBARRAY,C,IBDEL,IBDELO,IBMARK
.;get all possible scheduling data for patient
.S IBARRAY(0)=DFN
.;
.D LISTP^IBTRE20
.W !
.I C=0 S IBQUIT=1 Q
.S DIR("?")="Prosthetics"
.S DIR(0)="N",DIR("A")="Prosthetics Entry"
.D ^DIR K DIR
.I $D(DIRUT) S IBQUIT=1 Q
.I Y>0 S RC=IBARRAY(Y),IBDEL=$P(RC,U,3),IBPRO=$P(RC,U,4),PIEN=$P(RC,U,1),IBPR=$P(RC,U,2),IBDELO=$P(RC,U,5)
.;
.; ask if okay to add entry.
.S Y=IBDEL D D^DIQ S IBTDTE=Y
.S DIR(0)="Y",DIR("A")="Okay to Add Claims Tracking entry for Prosthetics "_IBPRO_" for "_IBDELO,DIR("B")="NO"
.D ^DIR K DIR I $D(DIRUT)!('Y) S IBQUIT=1 Q
.S PCOV=$$PTCOV^IBCNSU3(DFN,IBDEL,"PROSTHETICS")
.S IBMARK="" I 'PCOV S IBMARK="NO PROSTHETIC COVERAGE"
.D PRO^IBTUTL1(DFN,IBDEL,PIEN,IBMARK)
.Q
;
I $G(IBQUIT) G ATQ
I $D(IBTASS) Q ; leave prematurely if from assign reason
;
I $G(IBTRN) N IBTATRK S IBTATRK=1 D QE1^IBTRE1
;
D BLD^IBTRE
;
ATQ Q:$D(IBTASS)
I $G(IBQUIT) W !,"Nothing Added",! D PAUSE^VALM1
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRE2 6154 printed Apr 09, 2024@21:22:12 Page 2
IBTRE2 ;ALB/AAS - CLAIMS TRACKING - ACTIONS ;27-JUN-93
+1 ;;2.0;INTEGRATED BILLING;**23,121,249,312,568**;21-MAR-94;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% GOTO EN^IBTRE
+1 ;
AT ; -- Add tracking entry
+1 ;IB*2.0*312
IF '$$PFSSWARN^IBBSHDWN()
SET VALMBCK="R"
QUIT
+2 DO FULL^VALM1
+3 NEW X,Y,DIC,DA,DR,DD,DO,DIR,DIRUT,DTOUT,DUOUT,IBETYP,IBQUIT,IBTDT,VAIN,VAINDT,IBTRN,IBTDTE
+4 NEW IBDEL,IBDELO,IBMARK,IBPR,IBPRO,PCOV,PIEN,RC
+5 ;
TEST SET IBQUIT=0
+1 ;568
SET DIC(0)="AEQMNZ"
SET DIC="^IBE(356.6,"
SET DIC("S")="I $P(^(0),U,3)<3!($P(^(0),U,3)=4)"
SET DIC("A")="Select Tracking Type: "
+2 DO ^DIC
KILL DIC
SET IBETYP=+Y
IF +Y<0
GOTO ATQ
+3 WRITE !
+4 ;
ADM IF IBETYP=$ORDER(^IBE(356.6,"AC",1,0))
Begin DoDot:1
+1 NEW DIR
+2 SET DIR("?")=" "
+3 SET DIR("?",1)=" Enter any Date!"
+4 SET DIR("?",2)=" "
+5 SET DIR("?",3)=" If the patient was an inpatient on that date the system will use the"
+6 SET DIR("?",4)=" correct admission date. If you are tracking an admissions at another"
+7 SET DIR("?",5)=" facility you may enter that date. Enter '??' to get a list of the"
+8 SET DIR("?",6)=" last 10 admissions for this patient."
+9 SET DIR("??")="^D LISTA^IBTRE20"
+10 SET DIR(0)="DO^::AEXTP"
SET DIR("A")="Admission Date"
+11 DO ^DIR
KILL DIR
SET (IBTDT,VAINDT)=+Y
IF $PIECE(VAINDT,".",2)=""
SET VAINDT=VAINDT+.24
+12 IF $DATA(DIRUT)!($PIECE(IBTDT,".")'?7N)
SET IBQUIT=1
QUIT
+13 ; -- check for valid admission
+14 ;look for one day admission
SET VA200=""
DO INP^VADPT
IF VAIN(1)=""
Begin DoDot:2
+15 SET IBX=+$ORDER(^(+$ORDER(^DGPM("ATID1",DFN,9999999-IBTDT)),0))
SET IBX=+$GET(^DGPM(IBX,0))
+16 ;9999999.9999999
IF $EXTRACT(IBX,1,7)=IBTDT
SET VAINDT=IBX
DO INP^VADPT
+17 IF VAIN(1)
WRITE !!,"WARNING: This appears to be a one day stay."
End DoDot:2
+18 IF VAIN(1)=""
Begin DoDot:2
+19 WRITE !!,*7,"WARNING: Patient does not appear to be an inpatient on this date!",!
+20 IF VAIN(7)=""
SET VAIN(7)=IBTDT
SET Y=IBTDT
DO D^DIQ
SET $PIECE(VAIN(7),"^",2)=Y
End DoDot:2
+21 ;
+22 SET DIR("?")="No admission was found for this date, enter 'Yes' if you want to add this anyway, or 'No' if you do not wish to track this date."
+23 SET DIR(0)="Y"
SET DIR("A")="Okay to Add Claims Tracking entry for Admission Date "_$PIECE(VAIN(7),"^",2)
SET DIR("B")="NO"
+24 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!('Y)
SET IBQUIT=1
QUIT
+25 IF VAIN(1)
DO ADM^IBTUTL(VAIN(1))
+26 IF 'VAIN(1)
DO OTH^IBTUTL(DFN,IBETYP,IBTDT)
+27 QUIT
End DoDot:1
IF IBQUIT
GOTO ATQ
+28 ;
OPT IF IBETYP=$ORDER(^IBE(356.6,"AC",2,0))
Begin DoDot:1
+1 ;
+2 NEW DIR,IBSD,IBARRAY
+3 ;get all possible scheduling data for patient
+4 KILL ^TMP($JOB,"SDAMA301")
+5 SET IBARRAY(4)=DFN
SET IBARRAY("SORT")="P"
SET IBARRAY("FLDS")="1;2;3;10;12"
SET IBSD=$$SDAPI^SDAMA301(.IBARRAY)
+6 ;
+7 SET DIR("?")="Time is Required."
+8 SET DIR("?",1)=" Enter the Outpatient Visit Date."
+9 SET DIR("?",2)=" If no scheduled visit is found you will be given a warning. Enter"
+10 SET DIR("?",3)=" '??' to get a list of scheduled visits between "_$$DAT1^IBOUTL(IBTBDT)_" and "_$$DAT1^IBOUTL(IBTEDT)_"."
+11 IF '$DATA(IBTASS)
SET DIR("?",4)=" Use the change date range action to change listing of scheduled Visits."
+12 SET DIR("??")="^D LISTO^IBTRE20"
+13 SET DIR(0)="DO^::AEXTP"
SET DIR("A")="Outpatient Visit Date"
+14 DO ^DIR
KILL DIR
SET IBTDT=Y
+15 IF $DATA(DIRUT)!($PIECE(IBTDT,".")'?7N)
SET IBQUIT=1
QUIT
+16 ;
+17 ; check scheduling and encounters file for entries
+18 SET X=$DATA(^TMP($JOB,"SDAMA301",DFN,IBTDT))
+19 ;
+20 IF 'X
IF IBSD<0
WRITE !!,*7,"WARNING: Unable to look up Visit information for this Patient"
XECUTE "N IBX S IBX=0 F S IBX=$O(^TMP($J,""SDAMA301"",IBX)) W !?5,IBX,?10,$G(^(IBX))"
+21 ;
+22 IF 'X
IF IBSD
SET Y=$ORDER(^TMP($JOB,"SDAMA301",DFN,$PIECE(IBTDT,".")))
IF $PIECE(IBTDT,".")=$PIECE(Y,".")
SET IBTDT=Y
SET X=1
+23 ;
+24 ; if non say so
+25 IF 'X
IF IBSD'=-1
WRITE !!,*7,"WARNING: No Visit information for this Patient for this date.",!
+26 ;
+27 ; ask if okay to add entry.
+28 SET Y=IBTDT
DO D^DIQ
SET IBTDTE=Y
+29 SET DIR(0)="Y"
SET DIR("A")="Okay to Add Claims Tracking entry for Visit Date "_IBTDTE
SET DIR("B")="NO"
+30 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!('Y)
SET IBQUIT=1
QUIT
+31 DO OPT^IBTUTL1(DFN,IBETYP,IBTDT,$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,IBTDT)),"^",12))
+32 KILL ^TMP($JOB,"SDAMA301")
+33 QUIT
End DoDot:1
IF IBQUIT
GOTO ATQ
+34 ;
SCH IF IBETYP=$ORDER(^IBE(356.6,"AC",5,0))
Begin DoDot:1
+1 NEW DIR
+2 SET DIR("?")=" "
+3 SET DIR("?",1)=" Enter date of the scheduled admission."
+4 SET DIR("?",2)=" If you use the scheduled admission package to schedule admissions"
+5 SET DIR("?",3)=" you may enter '??' to get a list of scheduled admissions between"
+6 SET DIR("?",4)=" "_$$DAT1^IBOUTL(IBTBDT)_" and "_$$DAT1^IBOUTL(IBTEDT)_". Use the change date range action"
+7 SET DIR("?",5)=" to change listing of scheduled admissions."
+8 SET DIR("?",5)=" This should be a future scheduled admission."
+9 SET DIR(0)="DO^::AEXT"
SET DIR("A")="Scheduled Admission Date"
+10 SET DIR("??")="^D LISTS^IBTRE20"
+11 DO ^DIR
KILL DIR
SET IBTDT=+Y
+12 IF $DATA(DIRUT)!($PIECE(IBTDT,".")'?7N)
SET IBQUIT=1
QUIT
+13 ; ask if okay to add entry.
+14 DO FINDS^IBTRE20
+15 SET Y=IBTDT
DO D^DIQ
SET IBTDTE=Y
+16 SET DIR(0)="Y"
SET DIR("A")="Okay to Add Claims Tracking entry for Scheduled Adm. Date "_IBTDTE
SET DIR("B")="NO"
+17 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!('Y)
SET IBQUIT=1
QUIT
+18 IF IBTDT\1'>DT
SET VAINDT=IBTDT\1+.24
DO INP^VADPT
IF $GET(VAIN(1))
Begin DoDot:2
+19 WRITE !!,"Patient an inpatient on this date, using inpatient admission."
+20 DO ADM^IBTUTL(VAIN(1))
End DoDot:2
QUIT
+21 DO SCH^IBTUTL2(DFN,IBTDT)
+22 QUIT
End DoDot:1
IF IBQUIT
GOTO ATQ
+23 ;
PRO IF IBETYP=$ORDER(^IBE(356.6,"AC",3,0))
Begin DoDot:1
+1 ;
+2 NEW DIR,IBSD,IBARRAY,C,IBDEL,IBDELO,IBMARK
+3 ;get all possible scheduling data for patient
+4 SET IBARRAY(0)=DFN
+5 ;
+6 DO LISTP^IBTRE20
+7 WRITE !
+8 IF C=0
SET IBQUIT=1
QUIT
+9 SET DIR("?")="Prosthetics"
+10 SET DIR(0)="N"
SET DIR("A")="Prosthetics Entry"
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+13 IF Y>0
SET RC=IBARRAY(Y)
SET IBDEL=$PIECE(RC,U,3)
SET IBPRO=$PIECE(RC,U,4)
SET PIEN=$PIECE(RC,U,1)
SET IBPR=$PIECE(RC,U,2)
SET IBDELO=$PIECE(RC,U,5)
+14 ;
+15 ; ask if okay to add entry.
+16 SET Y=IBDEL
DO D^DIQ
SET IBTDTE=Y
+17 SET DIR(0)="Y"
SET DIR("A")="Okay to Add Claims Tracking entry for Prosthetics "_IBPRO_" for "_IBDELO
SET DIR("B")="NO"
+18 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!('Y)
SET IBQUIT=1
QUIT
+19 SET PCOV=$$PTCOV^IBCNSU3(DFN,IBDEL,"PROSTHETICS")
+20 SET IBMARK=""
IF 'PCOV
SET IBMARK="NO PROSTHETIC COVERAGE"
+21 DO PRO^IBTUTL1(DFN,IBDEL,PIEN,IBMARK)
+22 QUIT
End DoDot:1
IF IBQUIT
GOTO ATQ
+23 ;
+24 IF $GET(IBQUIT)
GOTO ATQ
+25 ; leave prematurely if from assign reason
IF $DATA(IBTASS)
QUIT
+26 ;
+27 IF $GET(IBTRN)
NEW IBTATRK
SET IBTATRK=1
DO QE1^IBTRE1
+28 ;
+29 DO BLD^IBTRE
+30 ;
ATQ if $DATA(IBTASS)
QUIT
+1 IF $GET(IBQUIT)
WRITE !,"Nothing Added",!
DO PAUSE^VALM1
+2 SET VALMBCK="R"
+3 QUIT
