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

IBTRE4.m

Go to the documentation of this file. 
  1. IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ;1-SEP-93
  1.  ;;2.0;INTEGRATED BILLING;**10,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
  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 procedure
  1.  I IBETYP=2 D  G ENQ
  1.  .W !!,*7,"You must use the add/edit action on Check-out to add procedures to Outpatient Encounters.",!
  1.  .S VALMBCK="R"
  1.  ;
  1.  ; -- Inpatient procedure
  1.  Q:'IBDGPM
  1.  I IBETYP=1 D PROC(IBTRN,IBETYP) S VALMBCK="R"
  1.  ;
  1. ENQ ;
  1.  Q
  1.  ;
  1. PROC(IBTRN,IBETYP) ; -- add/edit procedure
  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 procedure for an admission",! D PAUSE^VALM1 G PROCQ
  1.  ;
  1.  S X="IOINHI;IOINORM" D ENDR^%ZISS
  1.  W !!,"--- ",IOINHI,"Procedure",IOINORM," --- "
  1.  S IBSEL="Add"
  1.  D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK(IBCNT,"A")
  1.  I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G PROCQ
  1.  I IBSEL="Add" D ADD(IBTRN)
  1.  I IBSEL D EDT(+$G(IBXY(+IBSEL)),".01;.03;"),CHECK(+$G(IBXY(+IBSEL)))
  1. PROCQ Q
  1.  ;
  1. CHECK(IBADG) ; Check active status of the ICD0 code (Code Set Versioning)
  1.  N IBZ,DIR,X,Y
  1.  S IBZ=$G(^IBT(356.91,+$G(IBADG),0)) Q:'IBZ
  1.  Q:$$ICD0ACT^IBACSV(+IBZ,$P(IBZ,U,3))
  1.  W !!,*7,"Warning! The Procedure Code ",$P($$ICD0^IBACSV(+IBZ),U)," is inactive on this date!"
  1.  S DIR(0)="EA",DIR("A")="Press <Enter> to continue" D ^DIR
  1.  Q
  1.  ;
  1. ADD(IBTRN,TYPE) ; -- Add a new procedure
  1.  ;
  1.  N DTOUT,DUTOU,X,Y,DIC,DIR,IBDATE,IBP,IBPN,IBPDT,IBADT,ICDVDT
  1.  ;Service date (for CSV)
  1.  S IBDATE=$$TRNDATE^IBACSV(IBTRN)
  1.  S IBADT=$G(^DGPM(+$$DGPM^IBTRE3(IBTRN),0)) ;Admission Date
  1.  S IBCNT=0
  1.  I '$G(TYPE) S TYPE=""
  1. NXT ; The Procedure Date has to be asked first for the Code Set Versioning requirements
  1.  ; Input Procedure Date
  1.  S DIR(0)="D",DIR("A")=$S(IBCNT<1:"Procedure Date",1:"Next Procedure Date")
  1.  S DIR("B")=$$DAT3^IBOUTL(IBDATE)
  1.  W:$G(IBCNT) !
  1.  S IBPDT=IBDATE D ^DIR K DIR G ADDQ:Y'?7N S IBPDT=+Y W "  ",$$DAT2^IBOUTL(IBPDT)
  1.  ; The same checking as in the Data Dictionary, file #356.91, field #.03 (PROCEDURE DATE):
  1.  I IBADT,(IBPDT+.9)<IBADT W !!,*7,"The Procedure Date cannot be earlier than Admission (",$$DAT3^IBOUTL(IBADT),")",! G NXT
  1.  ; Input Procedure (ICD0)
  1.  S DIC("A")="Select Procedure: "
  1.  S DIC("S")="I $$ICD0ACT^IBACSV(+Y,IBPDT)"
  1.  S ICDVDT=IBPDT ; for DD ID (versioned text)
  1.  S DIC="^ICD0(",DIC(0)="AEMQ",X=""
  1.  D ^DIC K DIC G ADDQ:Y'>0
  1.  S IBP=+Y,IBPN=$P(Y,U,2) ; Procedure IEN and name
  1.  ;I '$$ICD0ACT^IBACSV(IBP,IBPDT) W !!,*7,IBPN," is not active for the procedure date ("_$$DAT3^IBOUTL(IBPDT),").",! G NXT
  1.  I $D(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),IBP)) W !!,*7,IBPN," is already a procedure.",!
  1.  S IBCNT=IBCNT+1
  1.  S IBADG=$$NEW(IBP,IBTRN,TYPE,IBPDT)
  1.  I IBADG>0,TYPE'=3 G NXT ;D EDT(IBADG) G NXT
  1. ADDQ Q
  1.  ;
  1. NEW(ICDI,IBTRN,TYPE,IBPDT) ; -- 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.91,",DIC(0)="L",DLAYGO=356.91
  1.  D FILE^DICN S IBADG=+Y I Y'>0 G NEWQ
  1.  I '$G(IBPDT) S IBPDT=$P($P(^IBT(356,IBTRN,0),"^",6),".")
  1.  L +^IBT(356.91,IBADG) S $P(^IBT(356.91,IBADG,0),"^",2,3)=$$DGPM^IBTRE3(IBTRN)_"^"_IBPDT,DA=IBADG D IX1^DIK L -^IBT(356.91,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.91 I DR="" S DR=".03;"
  1.  S DA=IBADG,DIE="^IBT(356.91,"
  1.  Q:'$G(^IBT(356.91,DA,0))
  1.  L +^IBT(356.91,IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
  1.  D ^DIE
  1.  L -^IBT(356.91,IBADG)
  1. EDTQ Q
  1.  ;
  1. SET(IBTRN) ; -- set array
  1.  N IBDGPM,IBICD
  1.  S IBDGPM=$$DGPM^IBTRE3(IBTRN)
  1.  S (IBICD,IBDA,IBCNT)=0
  1.  F  S IBICD=$O(^IBT(356.91,"ADGPM",IBDGPM,IBICD)) Q:'IBICD  S IBDA=0 F  S IBDA=$O(^IBT(356.91,"ADGPM",IBDGPM,IBICD,IBDA)) Q:'IBDA  D
  1.  .Q:'$D(^IBT(356.91,+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.91,+IBXY(I),0))
  1.  . S IBDATE=$P($P(IBTNOD,U,3),".") ; Procedure date
  1.  . S IBXD=$$ICD0^IBACSV(+$P(IBXY(I),U,2),IBDATE)
  1.  . W !?2,I,"  ",$P(IBXD,U),?15,$E($P(IBXD,U,4),1,43),?60,$$DAT1^IBOUTL(IBDATE),?72,"ICD-",$S($P(IBXD,U,14)=2:9,1:10)
  1.  Q
  1.  ;
  1. ASK(IBCNT,IBPAR,IBSELDF) ;Ask user to select from list
  1.  ; Input  -- SDCNT    Number of Entities
  1.  ;           SDPAR    Selection Parameters (A=Add)
  1.  ;           SDSELDF  Selection Default  [Optional]
  1.  ; Output -- Selection
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. REASK S DIR("?")="Enter "_$S($G(IBSELDF)]"":"<RETURN> for '"_IBSELDF_"', ",1:"")_$S(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$S(IBPAR["A":", or 'A' to Add",1:"")
  1.  S DIR("A")="Enter "_$S(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$S(IBPAR["A":", or 'A' to Add",1:"")_": "_$S($G(IBSELDF)]"":IBSELDF_"// ",1:"")
  1.  S DIR(0)="FAO^1:30"
  1.  D ^DIR I $D(DTOUT)!($D(DUOUT)) S Y="^" G ASKQ
  1.  S Y=$$UPPER^VALM1(Y)
  1.  I Y?.N,Y,Y'>IBCNT G ASKQ
  1.  I IBPAR["A",$E(Y)="A" S Y="Add" G ASKQ
  1.  I Y="" S Y=$S($G(IBSELDF)]"":IBSELDF,1:"Return") G ASKQ
  1.  W !!?5,DIR("?"),".",! G REASK
  1. ASKQ Q $G(Y)