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

IBTRE3.m

Go to the documentation of this file.
  1. IBTRE3 ;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ;1-SEP-93
  1. ;;2.0;INTEGRATED BILLING;**10,60,210,266,461**;21-MAR-94;Build 58
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. % G ^IBTRE
  1. ;
  1. EN(IBTRN) ; -- entry point for protocols
  1. ; must do own rebuild actions
  1. ; -- Input - point to 356
  1. ;
  1. N IBETYP,IBTRND,IBXY,IBCNT,IBDGPM,IBSEL
  1. D FULL^VALM1
  1. S VALMBCK=""
  1. S IBTRND=$G(^IBT(356,+IBTRN,0)),IBDGPM=$P(IBTRND,"^",5)
  1. ;
  1. S IBETYP=$$TRTP^IBTRE1(IBTRN)
  1. I IBETYP>2 W !!,"Clinical Information comes from the parent package." D PAUSE^VALM1 G ENQ
  1. ;
  1. ; -- outpatient diagnosis
  1. I IBETYP=2 D G ENQ
  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. .S VALMBCK="R"
  1. ;
  1. ; -- Inpatient diagnosis
  1. I IBETYP=1 D
  1. .Q:'IBDGPM
  1. .;
  1. .; -- ask admitting diagnosis if not already there
  1. .I '$O(^IBT(356.9,"ADG",+IBDGPM,0)) D ADIAG(IBTRN,IBETYP)
  1. .I $G(IBSEL)="^" Q
  1. .;
  1. .; -- edit other diagnosis
  1. .D DIAG(IBTRN,IBETYP)
  1. .S VALMBCK="R"
  1. ;
  1. ENQ ;
  1. Q
  1. ADIAG(IBTRN,IBETYP) ; -- add admitting diagnosis
  1. ;
  1. N IBADG,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM,IBDATE
  1. S IBADG=""
  1. ;
  1. S IBDATE=$$TRNDATE^IBACSV(IBTRN) ; Service date for CSV
  1. ;
  1. ;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
  1. I IBETYP'=1!('IBDGPM) W !!,"You can only enter an admitting diagnosis for an admission",! D PAUSE^VALM1 G ADGQ
  1. ;
  1. S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. S IBADG=$O(^IBT(356.9,"ADG",IBDGPM,0)) I IBADG S IBDA=$O(^IBT(356.9,"ADG",IBDGPM,IBADG,0))
  1. W !!,"--- ",IOINHI,"Admitting Diagnosis",IOINORM," --- "
  1. I 'IBADG W "Unspecified"
  1. E D
  1. . N IBDX
  1. . S IBDX=$$ICD9^IBACSV(+IBADG,IBDATE)
  1. . W $P(IBDX,U)_" -"_$P(IBDX,U,3)
  1. I +IBADG D EDT(IBDA,".01;") W !
  1. I '$O(^IBT(356.9,"ADG",+IBDGPM,0)) D ADD(IBTRN,3)
  1. ;
  1. W !
  1. ADGQ Q
  1. ;
  1. DIAG(IBTRN,IBETYP) ; -- add/edit diagnosis
  1. Q:'IBTRN
  1. I $G(IBETYP)'=1 Q
  1. N DA,DR,DIC,DIE
  1. S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
  1. I IBETYP'=1!('IBDGPM) W !!,"You can only enter a diagnosis for an admission",! D PAUSE^VALM1 G ADGQ
  1. ;
  1. S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. W !!,"--- ",IOINHI,"Diagnosis",IOINORM," --- "
  1. S IBSEL="Add"
  1. D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK^IBTRE4(IBCNT,"A")
  1. I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G DIAGQ
  1. I IBSEL="Add" D ADD(IBTRN)
  1. D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;.04;.05")
  1. DIAGQ Q
  1. ;
  1. ADD(IBTRN,TYPE) ; -- Add a new diagnosis
  1. ;
  1. N DTOUT,DUOUT,X,Y,DIC,IBDATE,ICDVDT
  1. S IBCNT=0
  1. ;Service date (for CSV)
  1. S IBDATE=$$TRNDATE^IBACSV(IBTRN) S:'IBDATE IBDATE=DT
  1. S ICDVDT=IBDATE ; for DD ID (versioned text)
  1. ;
  1. I '$G(TYPE) S TYPE=""
  1. NXT S DIC("A")=$S(TYPE=3:"Admitting Diagnosis: ",IBCNT<1:"Select Diagnosis: ",1:"Next Diagnosis: ")
  1. ;
  1. ;All DX codes for a version are visible - screen on version (ICD9/ICD10) on date but allows inactive
  1. S DIC("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE)
  1. S DIC="^ICD9(",DIC(0)="AEMQI",X=""
  1. W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
  1. ;
  1. I Y,'$$ICD9ACT^IBACSV(+Y,IBDATE) W !!,*7,$P(Y,U,2)," is not active for the service date ("_$$DAT3^IBOUTL(IBDATE),").",! G NXT
  1. I $D(^IBT(356.9,"ADGPM",$$DGPM(IBTRN),+Y)) W !!,*7,$P(Y,"^",2)," is already a diagnosis.",! G NXT
  1. S IBCNT=IBCNT+1
  1. S IBADG=$$NEW(+Y,IBTRN,TYPE)
  1. I IBADG,TYPE'=3 D EDT(IBADG) G NXT
  1. ADDQ I $D(DTOUT)!($D(DUOUT)) S IBSEL="^"
  1. Q
  1. ;
  1. DGPM(IBTRN) ; -- return admission pointer
  1. Q $P(^IBT(356,+IBTRN,0),"^",5)
  1. ;
  1. ;
  1. NEW(ICDI,IBTRN,TYPE) ; -- file new entry
  1. ;
  1. N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
  1. S X=ICDI,(DIC,DIK)="^IBT(356.9,",DIC(0)="L",DLAYGO=356.9,DIC("DR")=".05////Y"
  1. D FILE^DICN S IBADG=+Y
  1. I IBADG>0 L +^IBT(356.9,IBADG) S $P(^IBT(356.9,IBADG,0),"^",2,4)=$$DGPM(IBTRN)_"^"_$P($P(^IBT(356,IBTRN,0),"^",6),".")_"^"_$G(TYPE),DA=IBADG D IX1^DIK L -^IBT(356.9,IBADG)
  1. NEWQ Q IBADG
  1. ;
  1. EDT(IBADG,IBDR) ; -- edit entry
  1. ;
  1. N DR,DIE,DA,DIDEL
  1. S DR=$G(IBDR),DIDEL=356.9 I DR="" S DR=".03;.04;.05"
  1. S DA=IBADG,DIE="^IBT(356.9,"
  1. Q:'$G(^IBT(356.9,DA,0))
  1. L +^IBT(356.9,+IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
  1. D ^DIE
  1. L -^IBT(356.9,+IBADG)
  1. EDTQ Q
  1. ;
  1. SET(IBTRN) ; -- set array
  1. N IBDGPM,IBICD,IBDA
  1. S IBDGPM=$$DGPM(IBTRN)
  1. S (IBICD,IBCNT)=0
  1. F S IBICD=$O(^IBT(356.9,"ADGPM",IBDGPM,IBICD)) Q:'IBICD S IBDA=0 F S IBDA=$O(^IBT(356.9,"ADGPM",IBDGPM,IBICD,IBDA)) Q:'IBDA D
  1. .Q:'$D(^IBT(356.9,+IBDA,0))
  1. .S IBCNT=IBCNT+1
  1. .S IBXY(IBCNT)=IBDA_"^"_IBICD
  1. SETQ Q
  1. ;
  1. LIST(IBXY) ;List Diagnosis Array
  1. ; Input -- IBXY Diagnosis Array Subscripted by a Number
  1. ; Output -- List Diagnosis Array
  1. N I,IBXD,IBDATE
  1. W !
  1. S I=0 F S I=$O(IBXY(I)) Q:'I D
  1. . S IBTNOD=$G(^IBT(356.9,+IBXY(I),0))
  1. . S IBDATE=$P($P(IBTNOD,U,3),".")
  1. . S IBXD=$$ICD9^IBACSV(+$P(IBXY(I),U,2),IBDATE)
  1. . W !?1,I," ",$P(IBXD,U),?14,$E($P(IBXD,U,3),1,30),?47,$$DAT1^IBOUTL(IBDATE),?58,$$EXPAND^IBTRE(356.9,.04,$P(IBTNOD,U,4)),?69,"ICD-",$S($P(IBXD,U,19)=1:9,1:10) I $P(IBTNOD,U,5)'="" W ?77,"(",$P(IBTNOD,U,5),")"
  1. Q