Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTRV2

IBTRV2.m

Go to the documentation of this file.
  1. IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ;19-JUL-93
  1. ;;2.0;INTEGRATED BILLING;**60,210,266,461**;21-MAR-94;Build 58
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. % G EN^IBTRV
  1. ;
  1. DA(IBTRN) ; -- Add Diagnosis
  1. ; -- bld = non-zero means not from main tracking entry.
  1. ;
  1. N IBETYP
  1. D FULL^VALM1
  1. I IBETYP=2 D
  1. .I $P(IBTRND,"^",4) D ASK^IBTUTL4(IBTRN,2)
  1. .I '$P(IBTRND,"^",4) W !!,"Can not add diagnosis to outpatient visits prior to Check-out.",! D PAUSE^VALM1
  1. I IBETYP=1 D EN^IBTRE3(IBTRN)
  1. I '$G(BLD) D DRG,BLD^IBTRV
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. PROC(IBTRN,IBETYP,BLD) ; -- Add Procedures
  1. ; -- bld = non-zero means not from main tracking entry.
  1. ;
  1. I '$G(BLD) D FULL^VALM1
  1. I IBETYP=2 W !!,"Outpatient Procedures should be entered using Add/Edit action in",!,"Appointment Management.",! D PAUSE^VALM1
  1. I IBETYP=1 D EN^IBTRE4(IBTRN)
  1. I '$G(BLD) D BLD^IBTRV
  1. S VALMBCK="R"
  1. Q
  1. PROV(IBTRN,IBETYP,BLD) ; -- Add Procedures
  1. ; -- bld = non-zero means not from main tracking entry.
  1. ;
  1. I '$G(BLD) D FULL^VALM1
  1. I IBETYP=1 D EN^IBTRE5(IBTRN)
  1. I IBETYP=2,$P(IBTRND,"^",4) D ASK^IBTUTL4(IBTRN,1)
  1. I IBETYP=3 W !!,"Provider information for Prescriptions comes from the pharmacy package silly.",! D PAUSE^VALM1
  1. I IBETYP=4 W !!,"Provider information for Prosthetics comes from the prothetics package silly.",! D PAUSE^VALM1
  1. I '$G(BLD) D BLD^IBTRV
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. DRG(IBTRN) ; -- entry point to compute drg
  1. ; generally called from ad or pr above caller does own rebuild
  1. N DIR,DA,DR,DIC,DIE,IBALOS,IBDRG,IBTRVD,DGPMCA,DX
  1. S DGPMCA=$P(^IBT(356,IBTRN,0),"^",5) Q:'DGPMCA
  1. ;
  1. ; -- can't compute drg if no primary(dxls) diagnosis
  1. S DX=$O(^IBT(356.9,"ATP",DGPMCA,1,0)) Q:'DX
  1. D DISPDRG(DGPMCA)
  1. ;
  1. S DIR("?")="Answer 'Yes' to compute and store a new interim drg, answer 'No' to quit."
  1. S DIR("A")="Ready to compute New Interim DRG",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR
  1. I Y=1 D
  1. .S IBDRG=$$COMDRG(IBTRN) Q:+IBDRG<1
  1. .W !!,"DRG computes to: ",IBDRG," - ",$$DRGTD^IBACSV(IBDRG,$$TRNDATE^IBACSV(IBTRN))
  1. .;
  1. .S IBDA=$O(^IBT(356.93,"AMVD",DGPMCA,DT,0))
  1. .I +IBDA<1 D
  1. ..K DD,DO
  1. ..S X=IBDRG
  1. ..S DIC="^IBT(356.93,",DIC(0)="L",DLAYGO=356.93
  1. ..S DIC("DR")=".02////"_DGPMCA_";.03////"_DT
  1. ..D FILE^DICN K DIC S IBDA=+Y
  1. .I +IBDA<1 Q
  1. .;
  1. .L +^IBT(356.93,IBDA):5 I '$T D LOCKED^IBTRCD1 Q
  1. .S DIE="^IBT(356.93,",DA=IBDA
  1. .S DR=".01////^S X=IBDRG;.01;S IBALOS=$$ALOS^IBTRV2(IBDRG,DT);.04//^S X=IBALOS;.05//^S X=$$DAYREM^IBTRV2(DGPMCA,IBALOS)"
  1. .D ^DIE W !
  1. .L -^IBT(356.93,+IBDA)
  1. Q
  1. ;
  1. DAYREM(DGPM,LOS) ; -- Compute days remaining
  1. N IBX,DIFF S IBX=LOS
  1. S DIFF=$$FMDIFF^XLFDT(DT,+$G(^DGPM(DGPM,0))) S:DIFF<0 DIFF=-DIFF
  1. S IBX=LOS-DIFF
  1. I IBX<0 S IBX=0
  1. Q IBX\1
  1. ;
  1. ALOS(X,Y) ; -- compute alos for drg for year
  1. ; input x = pointer to drg file
  1. ; y = date
  1. N IBDT,J
  1. S IBDT=0 F S IBDT=$O(^IBE(356.5,"ADR",X,IBDT)) Q:'IBDT!(IBDT>Y) D
  1. .S J=$O(^IBE(356.5,"ADR",X,IBDT,0))
  1. Q $P($G(^IBE(356.5,+$G(J),0)),"^",3)
  1. ;
  1. COMDRG(IBTRN) ; -- compute drg from tracking file
  1. ;*********************************************************
  1. ; -- needed variable
  1. ; SEX = m or f
  1. ; AGE = whole number 0-120
  1. ; ICDEXP = patient died during this episode
  1. ; ICDTRS = patient transfered to acute care facility
  1. ; ICDDMS = patient had irregular discharge
  1. ; ICDDX( = diagnosis codes
  1. ; ICDPOA( = POA indicator for dx
  1. ; ICDPRC( = procedure codes
  1. ;*********************************************************
  1. N SEX,AGE,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPOA,ICDPRC,DX,PR,I,J,IBCNT,ICDMDC,ICDDRG,ICDDATE
  1. N ICDCSYS,ICD0,ICDCDSY,ICDEDT,ICDX,ICDTMP,ICDRG,ICD10ORNIT,ICD10ORT,X1,X2,ICDSEX,ICDY ; ICDDRG clean-up
  1. S ICDDRG="",(ICDEXP,ICDTRS,ICDDMS,IBCNT)=0,DFN=$P(^IBT(356,IBTRN,0),"^",2)
  1. ;
  1. S SEX=$P($G(^DPT(DFN,0)),U,2)
  1. S AGE=$$FMDIFF^XLFDT(DT,$P($G(^DPT(DFN,0)),U,3))\365.25
  1. S DGPMA=$P(^IBT(356,IBTRN,0),"^",5) G:'DGPMA COMDRGQ
  1. ;
  1. S IBCNT=0,J=""
  1. 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)
  1. ;
  1. S IBCNT=0,J=""
  1. 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))
  1. ;
  1. I $D(ICDDX(1)) S ICDDATE=$$TRNDATE^IBACSV(IBTRN) D ^ICDDRG
  1. COMDRGQ Q ICDDRG
  1. ;
  1. DISPDRG(DGPMCA) ; -- Display drg's
  1. N I,J,IBDRG
  1. W !!,"Current Interim DRGs on File:"
  1. 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
  1. .S IBDRG=$G(^IBT(356.93,J,0))
  1. .W !?5,$$DAT1^IBOUTL($P(IBDRG,"^",3)),?16,+IBDRG," - ",$$DRGTD^IBACSV(+IBDRG,$P(IBDRG,"^",3))
  1. .S IBCNT=IBCNT+1
  1. I IBCNT<1 W !?5,"None on file."
  1. W !
  1. Q