IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ;1-SEP-93
;;2.0;INTEGRATED BILLING;**10,210,266,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
% G ^IBTRE
;
EN(IBTRN) ; -- entry point for protocols
; must do own rebuild actions
; -- Input - point to 356
;
N IBETYP,IBTRND,IBXY,IBCNT,IBDGPM
D FULL^VALM1
S VALMBCK=""
S IBTRND=$G(^IBT(356,IBTRN,0)),IBDGPM=$P(IBTRND,"^",5)
;
S IBETYP=$$TRTP^IBTRE1(IBTRN)
I IBETYP>2 W !!,"Clinical Information comes from the parent package." D PAUSE^VALM1 G ENQ
;
; -- outpatient procedure
I IBETYP=2 D G ENQ
.W !!,*7,"You must use the add/edit action on Check-out to add procedures to Outpatient Encounters.",!
.S VALMBCK="R"
;
; -- Inpatient procedure
Q:'IBDGPM
I IBETYP=1 D PROC(IBTRN,IBETYP) S VALMBCK="R"
;
ENQ ;
Q
;
PROC(IBTRN,IBETYP) ; -- add/edit procedure
Q:'IBTRN
I $G(IBETYP)'=1 Q
N DA,DR,DIC,DIE
;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
I IBETYP'=1!('IBDGPM) W !!,"You can only enter a procedure for an admission",! D PAUSE^VALM1 G PROCQ
;
S X="IOINHI;IOINORM" D ENDR^%ZISS
W !!,"--- ",IOINHI,"Procedure",IOINORM," --- "
S IBSEL="Add"
D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK(IBCNT,"A")
I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G PROCQ
I IBSEL="Add" D ADD(IBTRN)
I IBSEL D EDT(+$G(IBXY(+IBSEL)),".01;.03;"),CHECK(+$G(IBXY(+IBSEL)))
PROCQ Q
;
CHECK(IBADG) ; Check active status of the ICD0 code (Code Set Versioning)
N IBZ,DIR,X,Y
S IBZ=$G(^IBT(356.91,+$G(IBADG),0)) Q:'IBZ
Q:$$ICD0ACT^IBACSV(+IBZ,$P(IBZ,U,3))
W !!,*7,"Warning! The Procedure Code ",$P($$ICD0^IBACSV(+IBZ),U)," is inactive on this date!"
S DIR(0)="EA",DIR("A")="Press <Enter> to continue" D ^DIR
Q
;
ADD(IBTRN,TYPE) ; -- Add a new procedure
;
N DTOUT,DUTOU,X,Y,DIC,DIR,IBDATE,IBP,IBPN,IBPDT,IBADT,ICDVDT
;Service date (for CSV)
S IBDATE=$$TRNDATE^IBACSV(IBTRN)
S IBADT=$G(^DGPM(+$$DGPM^IBTRE3(IBTRN),0)) ;Admission Date
S IBCNT=0
I '$G(TYPE) S TYPE=""
NXT ; The Procedure Date has to be asked first for the Code Set Versioning requirements
; Input Procedure Date
S DIR(0)="D",DIR("A")=$S(IBCNT<1:"Procedure Date",1:"Next Procedure Date")
S DIR("B")=$$DAT3^IBOUTL(IBDATE)
W:$G(IBCNT) !
S IBPDT=IBDATE D ^DIR K DIR G ADDQ:Y'?7N S IBPDT=+Y W " ",$$DAT2^IBOUTL(IBPDT)
; The same checking as in the Data Dictionary, file #356.91, field #.03 (PROCEDURE DATE):
I IBADT,(IBPDT+.9)<IBADT W !!,*7,"The Procedure Date cannot be earlier than Admission (",$$DAT3^IBOUTL(IBADT),")",! G NXT
; Input Procedure (ICD0)
S DIC("A")="Select Procedure: "
S DIC("S")="I $$ICD0ACT^IBACSV(+Y,IBPDT)"
S ICDVDT=IBPDT ; for DD ID (versioned text)
S DIC="^ICD0(",DIC(0)="AEMQ",X=""
D ^DIC K DIC G ADDQ:Y'>0
S IBP=+Y,IBPN=$P(Y,U,2) ; Procedure IEN and name
;I '$$ICD0ACT^IBACSV(IBP,IBPDT) W !!,*7,IBPN," is not active for the procedure date ("_$$DAT3^IBOUTL(IBPDT),").",! G NXT
I $D(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),IBP)) W !!,*7,IBPN," is already a procedure.",!
S IBCNT=IBCNT+1
S IBADG=$$NEW(IBP,IBTRN,TYPE,IBPDT)
I IBADG>0,TYPE'=3 G NXT ;D EDT(IBADG) G NXT
ADDQ Q
;
NEW(ICDI,IBTRN,TYPE,IBPDT) ; -- file new entry
;
N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
S X=ICDI,(DIC,DIK)="^IBT(356.91,",DIC(0)="L",DLAYGO=356.91
D FILE^DICN S IBADG=+Y I Y'>0 G NEWQ
I '$G(IBPDT) S IBPDT=$P($P(^IBT(356,IBTRN,0),"^",6),".")
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)
NEWQ Q IBADG
;
EDT(IBADG,IBDR) ; -- edit entry
;
N DR,DIE,DA,DIDEL
S DR=$G(IBDR),DIDEL=356.91 I DR="" S DR=".03;"
S DA=IBADG,DIE="^IBT(356.91,"
Q:'$G(^IBT(356.91,DA,0))
L +^IBT(356.91,IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
D ^DIE
L -^IBT(356.91,IBADG)
EDTQ Q
;
SET(IBTRN) ; -- set array
N IBDGPM,IBICD
S IBDGPM=$$DGPM^IBTRE3(IBTRN)
S (IBICD,IBDA,IBCNT)=0
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
.Q:'$D(^IBT(356.91,+IBDA,0))
.S IBCNT=IBCNT+1
.S IBXY(IBCNT)=IBDA_"^"_IBICD
SETQ Q
;
LIST(IBXY) ;List Diagnosis Array
; Input -- IBXY Diagnosis Array Subscripted by a Number
; Output -- List Diagnosis Array
N I,IBXD,IBDATE
W !
S I=0 F S I=$O(IBXY(I)) Q:'I D
. S IBTNOD=$G(^IBT(356.91,+IBXY(I),0))
. S IBDATE=$P($P(IBTNOD,U,3),".") ; Procedure date
. S IBXD=$$ICD0^IBACSV(+$P(IBXY(I),U,2),IBDATE)
. 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)
Q
;
ASK(IBCNT,IBPAR,IBSELDF) ;Ask user to select from list
; Input -- SDCNT Number of Entities
; SDPAR Selection Parameters (A=Add)
; SDSELDF Selection Default [Optional]
; Output -- Selection
N DIR,DIRUT,DTOUT,DUOUT,X,Y
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:"")
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:"")
S DIR(0)="FAO^1:30"
D ^DIR I $D(DTOUT)!($D(DUOUT)) S Y="^" G ASKQ
S Y=$$UPPER^VALM1(Y)
I Y?.N,Y,Y'>IBCNT G ASKQ
I IBPAR["A",$E(Y)="A" S Y="Add" G ASKQ
I Y="" S Y=$S($G(IBSELDF)]"":IBSELDF,1:"Return") G ASKQ
W !!?5,DIR("?"),".",! G REASK
ASKQ Q $G(Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRE4 5465 printed Nov 22, 2024@17:37:53 Page 2
IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ;1-SEP-93
+1 ;;2.0;INTEGRATED BILLING;**10,210,266,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
% GOTO ^IBTRE
+1 ;
EN(IBTRN) ; -- entry point for protocols
+1 ; must do own rebuild actions
+2 ; -- Input - point to 356
+3 ;
+4 NEW IBETYP,IBTRND,IBXY,IBCNT,IBDGPM
+5 DO FULL^VALM1
+6 SET VALMBCK=""
+7 SET IBTRND=$GET(^IBT(356,IBTRN,0))
SET IBDGPM=$PIECE(IBTRND,"^",5)
+8 ;
+9 SET IBETYP=$$TRTP^IBTRE1(IBTRN)
+10 IF IBETYP>2
WRITE !!,"Clinical Information comes from the parent package."
DO PAUSE^VALM1
GOTO ENQ
+11 ;
+12 ; -- outpatient procedure
+13 IF IBETYP=2
Begin DoDot:1
+14 WRITE !!,*7,"You must use the add/edit action on Check-out to add procedures to Outpatient Encounters.",!
+15 SET VALMBCK="R"
End DoDot:1
GOTO ENQ
+16 ;
+17 ; -- Inpatient procedure
+18 if 'IBDGPM
QUIT
+19 IF IBETYP=1
DO PROC(IBTRN,IBETYP)
SET VALMBCK="R"
+20 ;
ENQ ;
+1 QUIT
+2 ;
PROC(IBTRN,IBETYP) ; -- add/edit procedure
+1 if 'IBTRN
QUIT
+2 IF $GET(IBETYP)'=1
QUIT
+3 NEW DA,DR,DIC,DIE
+4 ;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
+5 IF IBETYP'=1!('IBDGPM)
WRITE !!,"You can only enter a procedure for an admission",!
DO PAUSE^VALM1
GOTO PROCQ
+6 ;
+7 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+8 WRITE !!,"--- ",IOINHI,"Procedure",IOINORM," --- "
+9 SET IBSEL="Add"
+10 DO SET(IBTRN)
IF $DATA(IBXY)
DO LIST(.IBXY)
SET IBSEL=$$ASK(IBCNT,"A")
+11 IF IBSEL["^"!(IBSEL["Return")
if IBSEL["^"
SET IBQUIT=1
GOTO PROCQ
+12 IF IBSEL="Add"
DO ADD(IBTRN)
+13 IF IBSEL
DO EDT(+$GET(IBXY(+IBSEL)),".01;.03;")
DO CHECK(+$GET(IBXY(+IBSEL)))
PROCQ QUIT
+1 ;
CHECK(IBADG) ; Check active status of the ICD0 code (Code Set Versioning)
+1 NEW IBZ,DIR,X,Y
+2 SET IBZ=$GET(^IBT(356.91,+$GET(IBADG),0))
if 'IBZ
QUIT
+3 if $$ICD0ACT^IBACSV(+IBZ,$PIECE(IBZ,U,3))
QUIT
+4 WRITE !!,*7,"Warning! The Procedure Code ",$PIECE($$ICD0^IBACSV(+IBZ),U)," is inactive on this date!"
+5 SET DIR(0)="EA"
SET DIR("A")="Press <Enter> to continue"
DO ^DIR
+6 QUIT
+7 ;
ADD(IBTRN,TYPE) ; -- Add a new procedure
+1 ;
+2 NEW DTOUT,DUTOU,X,Y,DIC,DIR,IBDATE,IBP,IBPN,IBPDT,IBADT,ICDVDT
+3 ;Service date (for CSV)
+4 SET IBDATE=$$TRNDATE^IBACSV(IBTRN)
+5 ;Admission Date
SET IBADT=$GET(^DGPM(+$$DGPM^IBTRE3(IBTRN),0))
+6 SET IBCNT=0
+7 IF '$GET(TYPE)
SET TYPE=""
NXT ; The Procedure Date has to be asked first for the Code Set Versioning requirements
+1 ; Input Procedure Date
+2 SET DIR(0)="D"
SET DIR("A")=$SELECT(IBCNT<1:"Procedure Date",1:"Next Procedure Date")
+3 SET DIR("B")=$$DAT3^IBOUTL(IBDATE)
+4 if $GET(IBCNT)
WRITE !
+5 SET IBPDT=IBDATE
DO ^DIR
KILL DIR
if Y'?7N
GOTO ADDQ
SET IBPDT=+Y
WRITE " ",$$DAT2^IBOUTL(IBPDT)
+6 ; The same checking as in the Data Dictionary, file #356.91, field #.03 (PROCEDURE DATE):
+7 IF IBADT
IF (IBPDT+.9)<IBADT
WRITE !!,*7,"The Procedure Date cannot be earlier than Admission (",$$DAT3^IBOUTL(IBADT),")",!
GOTO NXT
+8 ; Input Procedure (ICD0)
+9 SET DIC("A")="Select Procedure: "
+10 SET DIC("S")="I $$ICD0ACT^IBACSV(+Y,IBPDT)"
+11 ; for DD ID (versioned text)
SET ICDVDT=IBPDT
+12 SET DIC="^ICD0("
SET DIC(0)="AEMQ"
SET X=""
+13 DO ^DIC
KILL DIC
if Y'>0
GOTO ADDQ
+14 ; Procedure IEN and name
SET IBP=+Y
SET IBPN=$PIECE(Y,U,2)
+15 ;I '$$ICD0ACT^IBACSV(IBP,IBPDT) W !!,*7,IBPN," is not active for the procedure date ("_$$DAT3^IBOUTL(IBPDT),").",! G NXT
+16 IF $DATA(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),IBP))
WRITE !!,*7,IBPN," is already a procedure.",!
+17 SET IBCNT=IBCNT+1
+18 SET IBADG=$$NEW(IBP,IBTRN,TYPE,IBPDT)
+19 ;D EDT(IBADG) G NXT
IF IBADG>0
IF TYPE'=3
GOTO NXT
ADDQ QUIT
+1 ;
NEW(ICDI,IBTRN,TYPE,IBPDT) ; -- file new entry
+1 ;
+2 NEW DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
+3 SET X=ICDI
SET (DIC,DIK)="^IBT(356.91,"
SET DIC(0)="L"
SET DLAYGO=356.91
+4 DO FILE^DICN
SET IBADG=+Y
IF Y'>0
GOTO NEWQ
+5 IF '$GET(IBPDT)
SET IBPDT=$PIECE($PIECE(^IBT(356,IBTRN,0),"^",6),".")
+6 LOCK +^IBT(356.91,IBADG)
SET $PIECE(^IBT(356.91,IBADG,0),"^",2,3)=$$DGPM^IBTRE3(IBTRN)_"^"_IBPDT
SET DA=IBADG
DO IX1^DIK
LOCK -^IBT(356.91,IBADG)
NEWQ QUIT IBADG
+1 ;
EDT(IBADG,IBDR) ; -- edit entry
+1 ;
+2 NEW DR,DIE,DA,DIDEL
+3 SET DR=$GET(IBDR)
SET DIDEL=356.91
IF DR=""
SET DR=".03;"
+4 SET DA=IBADG
SET DIE="^IBT(356.91,"
+5 if '$GET(^IBT(356.91,DA,0))
QUIT
+6 LOCK +^IBT(356.91,IBADG):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDTQ
+7 DO ^DIE
+8 LOCK -^IBT(356.91,IBADG)
EDTQ QUIT
+1 ;
SET(IBTRN) ; -- set array
+1 NEW IBDGPM,IBICD
+2 SET IBDGPM=$$DGPM^IBTRE3(IBTRN)
+3 SET (IBICD,IBDA,IBCNT)=0
+4 FOR
SET IBICD=$ORDER(^IBT(356.91,"ADGPM",IBDGPM,IBICD))
if 'IBICD
QUIT
SET IBDA=0
FOR
SET IBDA=$ORDER(^IBT(356.91,"ADGPM",IBDGPM,IBICD,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+5 if '$DATA(^IBT(356.91,+IBDA,0))
QUIT
+6 SET IBCNT=IBCNT+1
+7 SET IBXY(IBCNT)=IBDA_"^"_IBICD
End DoDot:1
SETQ QUIT
+1 ;
LIST(IBXY) ;List Diagnosis Array
+1 ; Input -- IBXY Diagnosis Array Subscripted by a Number
+2 ; Output -- List Diagnosis Array
+3 NEW I,IBXD,IBDATE
+4 WRITE !
+5 SET I=0
FOR
SET I=$ORDER(IBXY(I))
if 'I
QUIT
Begin DoDot:1
+6 SET IBTNOD=$GET(^IBT(356.91,+IBXY(I),0))
+7 ; Procedure date
SET IBDATE=$PIECE($PIECE(IBTNOD,U,3),".")
+8 SET IBXD=$$ICD0^IBACSV(+$PIECE(IBXY(I),U,2),IBDATE)
+9 WRITE !?2,I," ",$PIECE(IBXD,U),?15,$EXTRACT($PIECE(IBXD,U,4),1,43),?60,$$DAT1^IBOUTL(IBDATE),?72,"ICD-",$SELECT($PIECE(IBXD,U,14)=2:9,1:10)
End DoDot:1
+10 QUIT
+11 ;
ASK(IBCNT,IBPAR,IBSELDF) ;Ask user to select from list
+1 ; Input -- SDCNT Number of Entities
+2 ; SDPAR Selection Parameters (A=Add)
+3 ; SDSELDF Selection Default [Optional]
+4 ; Output -- Selection
+5 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
REASK SET DIR("?")="Enter "_$SELECT($GET(IBSELDF)]"":"<RETURN> for '"_IBSELDF_"', ",1:"")_$SELECT(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$SELECT(IBPAR["A":", or 'A' to Add",1:"")
+1 SET DIR("A")="Enter "_$SELECT(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$SELECT(IBPAR["A":", or 'A' to Add",1:"")_": "_$SELECT($GET(IBSELDF)]"":IBSELDF_"// ",1:"")
+2 SET DIR(0)="FAO^1:30"
+3 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET Y="^"
GOTO ASKQ
+4 SET Y=$$UPPER^VALM1(Y)
+5 IF Y?.N
IF Y
IF Y'>IBCNT
GOTO ASKQ
+6 IF IBPAR["A"
IF $EXTRACT(Y)="A"
SET Y="Add"
GOTO ASKQ
+7 IF Y=""
SET Y=$SELECT($GET(IBSELDF)]"":IBSELDF,1:"Return")
GOTO ASKQ
+8 WRITE !!?5,DIR("?"),".",!
GOTO REASK
ASKQ QUIT $GET(Y)
