IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ; 19-JUL-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% G EN^IBTRV
;
DA(IBTRN) ; -- Add Diagnosis
; -- bld = non-zero means not from main tracking entry.
;
N IBETYP
D FULL^VALM1
I IBETYP=2 D
.I $P(IBTRND,"^",4) D ASK^SDCO4(+$P(IBTRND,"^",4)) K SDCOQUIT
.I '$P(IBTRND,"^",4) W !!,"Can not add diagnosis to outpatient visits prior to Check-out.",! D PAUSE^VALM1
I IBETYP=1 D EN^IBTRE3(IBTRN)
I '$G(BLD) D DRG,BLD^IBTRV
S VALMBCK="R"
Q
;
PROC(IBTRN,IBETYP,BLD) ; -- Add Procedures
; -- bld = non-zero means not from main tracking entry.
;
I '$G(BLD) D FULL^VALM1
I IBETYP=2 W !!,"Outpatient Procedures should be entered using Add/Edit action in",!,"Appointment Management.",! D PAUSE^VALM1
I IBETYP=1 D EN^IBTRE4(IBTRN)
I '$G(BLD) D BLD^IBTRV
S VALMBCK="R"
Q
PROV(IBTRN,IBETYP,BLD) ; -- Add Procedures
; -- bld = non-zero means not from main tracking entry.
;
I '$G(BLD) D FULL^VALM1
I IBETYP=1 D EN^IBTRE5(IBTRN)
I IBETYP=2,$P(IBTRND,"^",4) D ASK^SDCO3(+$P(IBTRND,"^",4)) K SDCOQUIT
I IBETYP=3 W !!,"Provider information for Prescriptions comes from the pharmacy package silly.",! D PAUSE^VALM1
I IBETYP=4 W !!,"Provider information for Prosthetics comes from the prothetics package silly.",! D PAUSE^VALM1
I '$G(BLD) D BLD^IBTRV
S VALMBCK="R"
Q
;
DRG(IBTRN) ; -- entry point to compute drg
; generally called from ad or pr above caller does own rebuild
N DIR,DA,DR,DIC,DIE,IBALOS,IBDRG,IBTRVD,DGPMCA,DX
S DGPMCA=$P(^IBT(356,IBTRN,0),"^",5) Q:'DGPMCA
;
; -- can't compute drg if no primary(dxls) diagnosis
S DX=$O(^IBT(356.9,"ATP",DGPMCA,1,0)) Q:'DX
D DISPDRG(DGPMCA)
;
S DIR("?")="Answer 'Yes' to compute and store a new interim drg, answer 'No' to quit."
S DIR("A")="Ready to compute New Interim DRG",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR
I Y=1 D
.S IBDRG=$$COMDRG(IBTRN) Q:+IBDRG<1
.W !!,"DRG computes to: ",IBDRG," - ",$G(^ICD(IBDRG,1,1,0))
.;
.S IBDA=$O(^IBT(356.93,"AMVD",DGPMCA,DT,0))
.I +IBDA<1 D
..K DD,DO
..S X=IBDRG
..S DIC="^IBT(356.93,",DIC(0)="L",DLAYGO=356.93
..S DIC("DR")=".02////"_DGPMCA_";.03////"_DT
..D FILE^DICN K DIC S IBDA=+Y
.I +IBDA<1 Q
.;
.L +^IBT(356.93,IBDA):5 I '$T D LOCKED^IBTRCD1 Q
.S DIE="^IBT(356.93,",DA=IBDA
.S DR=".01////^S X=IBDRG;.01;S IBALOS=$$ALOS^IBTRV2(IBDRG,DT);.04//^S X=IBALOS;.05//^S X=$$DAYREM^IBTRV2(DGPMCA,IBALOS)"
.D ^DIE W !
.L -^IBT(356.93,+IBDA)
Q
;
DAYREM(DGPM,LOS) ; -- Compute days remaining
N IBX,DIFF S IBX=LOS
S DIFF=$$FMDIFF^XLFDT(DT,+$G(^DGPM(DGPM,0))) S:DIFF<0 DIFF=-DIFF
S IBX=LOS-DIFF
I IBX<0 S IBX=0
Q IBX\1
;
ALOS(X,Y) ; -- compute alos for drg for year
; input x = pointer to drg file
; y = date
N IBDT,J
S IBDT=0 F S IBDT=$O(^IBE(356.5,"ADR",X,IBDT)) Q:'IBDT!(IBDT>Y) D
.S J=$O(^IBE(356.5,"ADR",X,IBDT,0))
Q $P($G(^IBE(356.5,+$G(J),0)),"^",3)
;
COMDRG(IBTRN) ; -- compute drg from tracking file
;*********************************************************
; -- needed variable
; SEX = m or f
; AGE = whole number 0-120
; ICDEXP = patient died during this episode
; ICDTRS = patient transfered to acute care facility
; ICDDMS = patient had irregular discharge
; ICDDX( = diagnosis codes
; ICDPRC( = procedure codes
;*********************************************************
N SEX,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPRC,DX,PR,I,J,IBCNT,ICDMDC,ICDDRG
S ICDDRG="",(ICDEXP,ICDTRS,ICDDMS,IBCNT)=0,DFN=$P(^IBT(356,IBTRN,0),"^",2)
;
S SEX=$P($G(^DPT(DFN,0)),U,2)
S AGE=$$FMDIFF^XLFDT(DT,$P($G(^DPT(DFN,0)),U,3))\365.25
S DGPMA=$P(^IBT(356,IBTRN,0),"^",5) G:'DGPMA COMDRGQ
;
S IBCNT=1,DX=0
S ICDDX(1)=+$G(^IBT(356.9,+$O(^IBT(356.9,"ATP",DGPMA,+$O(^IBT(356.9,"ATP",DGPMA,0)),0)),0))
F S DX=$O(^IBT(356.9,"C",DGPMA,DX)) Q:'DX S X=$G(^IBT(356.9,DX,0)) I $P(X,"^",4)=2 S IBCNT=IBCNT+1,ICDDX(IBCNT)=+X
;
S IBCNT=0,J=""
F S J=$O(^IBT(356.91,"APP",DGPMA,J)) Q:'J S PR="" F S PR=$O(^IBT(356.91,"APP",DGPMA,J,PR)) Q:'PR S IBCNT=IBCNT+1,ICDPRC(IBCNT)=+$G(^IBT(356.91,PR,0))
;
I $D(ICDDX(1)) D ^ICDDRG
COMDRGQ Q ICDDRG
;
DISPDRG(DGPMCA) ; -- Display drg's
N I,J,IBDRG
W !!,"Current Interim DRGs on File:"
S I=0,IBCNT=0 F S I=$O(^IBT(356.93,"AMVD",DGPMCA,I)) Q:'I S J=0 F S J=$O(^IBT(356.93,"AMVD",DGPMCA,I,J)) Q:'J D
.S IBDRG=$G(^IBT(356.93,J,0))
.W !?5,$$DAT1^IBOUTL($P(IBDRG,"^",3)),?16,+IBDRG," - ",$G(^ICD(+IBDRG,1,1,0))
.S IBCNT=IBCNT+1
I IBCNT<1 W !?5,"None on file."
W !
Q
IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ; 19-JUL-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% GOTO EN^IBTRV
+1 ;
DA(IBTRN) ; -- Add Diagnosis
+1 ; -- bld = non-zero means not from main tracking entry.
+2 ;
+3 NEW IBETYP
+4 DO FULL^VALM1
+5 IF IBETYP=2
Begin DoDot:1
+6 IF $PIECE(IBTRND,"^",4)
DO ASK^SDCO4(+$PIECE(IBTRND,"^",4))
KILL SDCOQUIT
+7 IF '$PIECE(IBTRND,"^",4)
WRITE !!,"Can not add diagnosis to outpatient visits prior to Check-out.",!
DO PAUSE^VALM1
End DoDot:1
+8 IF IBETYP=1
DO EN^IBTRE3(IBTRN)
+9 IF '$GET(BLD)
DO DRG
DO BLD^IBTRV
+10 SET VALMBCK="R"
+11 QUIT
+12 ;
PROC(IBTRN,IBETYP,BLD) ; -- Add Procedures
+1 ; -- bld = non-zero means not from main tracking entry.
+2 ;
+3 IF '$GET(BLD)
DO FULL^VALM1
+4 IF IBETYP=2
WRITE !!,"Outpatient Procedures should be entered using Add/Edit action in",!,"Appointment Management.",!
DO PAUSE^VALM1
+5 IF IBETYP=1
DO EN^IBTRE4(IBTRN)
+6 IF '$GET(BLD)
DO BLD^IBTRV
+7 SET VALMBCK="R"
+8 QUIT
PROV(IBTRN,IBETYP,BLD) ; -- Add Procedures
+1 ; -- bld = non-zero means not from main tracking entry.
+2 ;
+3 IF '$GET(BLD)
DO FULL^VALM1
+4 IF IBETYP=1
DO EN^IBTRE5(IBTRN)
+5 IF IBETYP=2
IF $PIECE(IBTRND,"^",4)
DO ASK^SDCO3(+$PIECE(IBTRND,"^",4))
KILL SDCOQUIT
+6 IF IBETYP=3
WRITE !!,"Provider information for Prescriptions comes from the pharmacy package silly.",!
DO PAUSE^VALM1
+7 IF IBETYP=4
WRITE !!,"Provider information for Prosthetics comes from the prothetics package silly.",!
DO PAUSE^VALM1
+8 IF '$GET(BLD)
DO BLD^IBTRV
+9 SET VALMBCK="R"
+10 QUIT
+11 ;
DRG(IBTRN) ; -- entry point to compute drg
+1 ; generally called from ad or pr above caller does own rebuild
+2 NEW DIR,DA,DR,DIC,DIE,IBALOS,IBDRG,IBTRVD,DGPMCA,DX
+3 SET DGPMCA=$PIECE(^IBT(356,IBTRN,0),"^",5)
IF 'DGPMCA
QUIT
+4 ;
+5 ; -- can't compute drg if no primary(dxls) diagnosis
+6 SET DX=$ORDER(^IBT(356.9,"ATP",DGPMCA,1,0))
IF 'DX
QUIT
+7 DO DISPDRG(DGPMCA)
+8 ;
+9 SET DIR("?")="Answer 'Yes' to compute and store a new interim drg, answer 'No' to quit."
+10 SET DIR("A")="Ready to compute New Interim DRG"
SET DIR("B")="NO"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
+11 IF Y=1
Begin DoDot:1
+12 SET IBDRG=$$COMDRG(IBTRN)
IF +IBDRG<1
QUIT
+13 WRITE !!,"DRG computes to: ",IBDRG," - ",$GET(^ICD(IBDRG,1,1,0))
+14 ;
+15 SET IBDA=$ORDER(^IBT(356.93,"AMVD",DGPMCA,DT,0))
+16 IF +IBDA<1
Begin DoDot:2
+17 KILL DD,DO
+18 SET X=IBDRG
+19 SET DIC="^IBT(356.93,"
SET DIC(0)="L"
SET DLAYGO=356.93
+20 SET DIC("DR")=".02////"_DGPMCA_";.03////"_DT
+21 DO FILE^DICN
KILL DIC
SET IBDA=+Y
End DoDot:2
+22 IF +IBDA<1
QUIT
+23 ;
+24 LOCK +^IBT(356.93,IBDA):5
IF '$TEST
DO LOCKED^IBTRCD1
QUIT
+25 SET DIE="^IBT(356.93,"
SET DA=IBDA
+26 SET DR=".01////^S X=IBDRG;.01;S IBALOS=$$ALOS^IBTRV2(IBDRG,DT);.04//^S X=IBALOS;.05//^S X=$$DAYREM^IBTRV2(DGPMCA,IBALOS)"
+27 DO ^DIE
WRITE !
+28 LOCK -^IBT(356.93,+IBDA)
End DoDot:1
+29 QUIT
+30 ;
DAYREM(DGPM,LOS) ; -- Compute days remaining
+1 NEW IBX,DIFF
SET IBX=LOS
+2 SET DIFF=$$FMDIFF^XLFDT(DT,+$GET(^DGPM(DGPM,0)))
IF DIFF<0
SET DIFF=-DIFF
+3 SET IBX=LOS-DIFF
+4 IF IBX<0
SET IBX=0
+5 QUIT IBX\1
+6 ;
ALOS(X,Y) ; -- compute alos for drg for year
+1 ; input x = pointer to drg file
+2 ; y = date
+3 NEW IBDT,J
+4 SET IBDT=0
FOR
SET IBDT=$ORDER(^IBE(356.5,"ADR",X,IBDT))
IF 'IBDT!(IBDT>Y)
QUIT
Begin DoDot:1
+5 SET J=$ORDER(^IBE(356.5,"ADR",X,IBDT,0))
End DoDot:1
+6 QUIT $PIECE($GET(^IBE(356.5,+$GET(J),0)),"^",3)
+7 ;
COMDRG(IBTRN) ; -- compute drg from tracking file
+1 ;*********************************************************
+2 ; -- needed variable
+3 ; SEX = m or f
+4 ; AGE = whole number 0-120
+5 ; ICDEXP = patient died during this episode
+6 ; ICDTRS = patient transfered to acute care facility
+7 ; ICDDMS = patient had irregular discharge
+8 ; ICDDX( = diagnosis codes
+9 ; ICDPRC( = procedure codes
+10 ;*********************************************************
+11 NEW SEX,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPRC,DX,PR,I,J,IBCNT,ICDMDC,ICDDRG
+12 SET ICDDRG=""
SET (ICDEXP,ICDTRS,ICDDMS,IBCNT)=0
SET DFN=$PIECE(^IBT(356,IBTRN,0),"^",2)
+13 ;
+14 SET SEX=$PIECE($GET(^DPT(DFN,0)),U,2)
+15 SET AGE=$$FMDIFF^XLFDT(DT,$PIECE($GET(^DPT(DFN,0)),U,3))\365.25
+16 SET DGPMA=$PIECE(^IBT(356,IBTRN,0),"^",5)
IF 'DGPMA
GOTO COMDRGQ
+17 ;
+18 SET IBCNT=1
SET DX=0
+19 SET ICDDX(1)=+$GET(^IBT(356.9,+$ORDER(^IBT(356.9,"ATP",DGPMA,+$ORDER(^IBT(356.9,"ATP",DGPMA,0)),0)),0))
+20 FOR
SET DX=$ORDER(^IBT(356.9,"C",DGPMA,DX))
IF 'DX
QUIT
SET X=$GET(^IBT(356.9,DX,0))
IF $PIECE(X,"^",4)=2
SET IBCNT=IBCNT+1
SET ICDDX(IBCNT)=+X
+21 ;
+22 SET IBCNT=0
SET J=""
+23 FOR
SET J=$ORDER(^IBT(356.91,"APP",DGPMA,J))
IF 'J
QUIT
SET PR=""
FOR
SET PR=$ORDER(^IBT(356.91,"APP",DGPMA,J,PR))
IF 'PR
QUIT
SET IBCNT=IBCNT+1
SET ICDPRC(IBCNT)=+$GET(^IBT(356.91,PR,0))
+24 ;
+25 IF $DATA(ICDDX(1))
DO ^ICDDRG
COMDRGQ QUIT ICDDRG
+1 ;
DISPDRG(DGPMCA) ; -- Display drg's
+1 NEW I,J,IBDRG
+2 WRITE !!,"Current Interim DRGs on File:"
+3 SET I=0
SET IBCNT=0
FOR
SET I=$ORDER(^IBT(356.93,"AMVD",DGPMCA,I))
IF 'I
QUIT
SET J=0
FOR
SET J=$ORDER(^IBT(356.93,"AMVD",DGPMCA,I,J))
IF 'J
QUIT
Begin DoDot:1
+4 SET IBDRG=$GET(^IBT(356.93,J,0))
+5 WRITE !?5,$$DAT1^IBOUTL($PIECE(IBDRG,"^",3)),?16,+IBDRG," - ",$GET(^ICD(+IBDRG,1,1,0))
+6 SET IBCNT=IBCNT+1
End DoDot:1
+7 IF IBCNT<1
WRITE !?5,"None on file."
+8 WRITE !
+9 QUIT
