- IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ;19-JUL-93
- ;;2.0;INTEGRATED BILLING;**60,210,266,461**;21-MAR-94;Build 58
- ;;Per VHA Directive 2004-038, 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^IBTUTL4(IBTRN,2)
- .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^IBTUTL4(IBTRN,1)
- 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," - ",$$DRGTD^IBACSV(IBDRG,$$TRNDATE^IBACSV(IBTRN))
- .;
- .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
- ; ICDPOA( = POA indicator for dx
- ; ICDPRC( = procedure codes
- ;*********************************************************
- N SEX,AGE,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPOA,ICDPRC,DX,PR,I,J,IBCNT,ICDMDC,ICDDRG,ICDDATE
- N ICDCSYS,ICD0,ICDCDSY,ICDEDT,ICDX,ICDTMP,ICDRG,ICD10ORNIT,ICD10ORT,X1,X2,ICDSEX,ICDY ; ICDDRG clean-up
- 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=0,J=""
- F S J=$O(^IBT(356.9,"ATP",DGPMA,J)) Q:'J S DX=0 F S DX=$O(^IBT(356.9,"ATP",DGPMA,J,DX)) Q:'DX S X=$G(^IBT(356.9,DX,0)) I $P(X,U,4)<3 S IBCNT=IBCNT+1,ICDDX(IBCNT)=+X,ICDPOA(IBCNT)=$P(X,U,5)
- ;
- 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)) S ICDDATE=$$TRNDATE^IBACSV(IBTRN) 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," - ",$$DRGTD^IBACSV(+IBDRG,$P(IBDRG,"^",3))
- .S IBCNT=IBCNT+1
- I IBCNT<1 W !?5,"None on file."
- W !
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRV2 4845 printed Feb 18, 2025@23:55:26 Page 2
- IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ;19-JUL-93
- +1 ;;2.0;INTEGRATED BILLING;**60,210,266,461**;21-MAR-94;Build 58
- +2 ;;Per VHA Directive 2004-038, 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^IBTUTL4(IBTRN,2)
- +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^IBTUTL4(IBTRN,1)
- +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," - ",$$DRGTD^IBACSV(IBDRG,$$TRNDATE^IBACSV(IBTRN))
- +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 ; ICDPOA( = POA indicator for dx
- +10 ; ICDPRC( = procedure codes
- +11 ;*********************************************************
- +12 NEW SEX,AGE,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPOA,ICDPRC,DX,PR,I,J,IBCNT,ICDMDC,ICDDRG,ICDDATE
- +13 ; ICDDRG clean-up
- NEW ICDCSYS,ICD0,ICDCDSY,ICDEDT,ICDX,ICDTMP,ICDRG,ICD10ORNIT,ICD10ORT,X1,X2,ICDSEX,ICDY
- +14 SET ICDDRG=""
- SET (ICDEXP,ICDTRS,ICDDMS,IBCNT)=0
- SET DFN=$PIECE(^IBT(356,IBTRN,0),"^",2)
- +15 ;
- +16 SET SEX=$PIECE($GET(^DPT(DFN,0)),U,2)
- +17 SET AGE=$$FMDIFF^XLFDT(DT,$PIECE($GET(^DPT(DFN,0)),U,3))\365.25
- +18 SET DGPMA=$PIECE(^IBT(356,IBTRN,0),"^",5)
- if 'DGPMA
- GOTO COMDRGQ
- +19 ;
- +20 SET IBCNT=0
- SET J=""
- +21 FOR
- SET J=$ORDER(^IBT(356.9,"ATP",DGPMA,J))
- if 'J
- QUIT
- SET DX=0
- FOR
- SET DX=$ORDER(^IBT(356.9,"ATP",DGPMA,J,DX))
- if 'DX
- QUIT
- SET X=$GET(^IBT(356.9,DX,0))
- IF $PIECE(X,U,4)<3
- SET IBCNT=IBCNT+1
- SET ICDDX(IBCNT)=+X
- SET ICDPOA(IBCNT)=$PIECE(X,U,5)
- +22 ;
- +23 SET IBCNT=0
- SET J=""
- +24 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))
- +25 ;
- +26 IF $DATA(ICDDX(1))
- SET ICDDATE=$$TRNDATE^IBACSV(IBTRN)
- 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," - ",$$DRGTD^IBACSV(+IBDRG,$PIECE(IBDRG,"^",3))
- +6 SET IBCNT=IBCNT+1
- End DoDot:1
- +7 IF IBCNT<1
- WRITE !?5,"None on file."
- +8 WRITE !
- +9 QUIT