IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ; 1-SEP-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, 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)
D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;")
PROCQ Q
;
ADD(IBTRN,TYPE) ; -- Add a new procedure
;
N DTOUT,DUTOU,X,Y,DIC
S IBCNT=0
I '$G(TYPE) S TYPE=""
NXT S DIC("A")=$S(IBCNT<1:"Select Procedure: ",1:"Next Procedure: ")
S DIC("S")="I '$P(^(0),U,9)"
S DIC="^ICD0(",DIC(0)="AEMQ",X=""
W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
I $D(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),+Y)) W !!,*7,$P(Y,"^",2)," is already a procedure.",!
S IBCNT=IBCNT+1
S IBADG=$$NEW(+Y,IBTRN,TYPE)
I IBADG,TYPE'=3 D EDT(IBADG) G NXT
ADDQ Q
;
NEW(ICDI,IBTRN,TYPE) ; -- 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 IBADG>0 L +^IBT(356.91,IBADG) S $P(^IBT(356.91,IBADG,0),"^",2,4)=$$DGPM^IBTRE3(IBTRN)_"^"_$P($P(^IBT(356,IBTRN,0),"^",6),"."),DA=IBADG D IX1^DIK L -^IBT(356.91,IBADG)
NEWQ Q IBADG
;
EDT(IBADG,IBDR) ; -- edit entry
;
N DR,DIE,DA
S DR=$G(IBDR) I DR="" S DR=".03;"
S DA=IBADG,DIE="^IBT(356.91,"
L +^IBT(356.91,IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
Q:'$G(^IBT(356.91,DA,0))
L -^IBT(356.91,IBADG)
D ^DIE
EDTQ Q
;
SET(IBTRN) ; -- set array
N IBDGPM,IBICD
S IBDGPM=$$DGPM^IBTRE3(IBTRN)
S (IBICD,IBCNT)=0
F S IBICD=$O(^IBT(356.91,"ADGPM",IBDGPM,IBICD)) Q:'IBICD S IBDA=$O(^(IBICD,0)) D
.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
W !
S I=0 F S I=$O(IBXY(I)) Q:'I S IBXD=$G(^ICD0(+$P(IBXY(I),"^",2),0)) D
.S IBTNOD=$G(^IBT(356.91,+IBXY(I),0))
.W !?2,I," ",$P(IBXD,"^"),?15,$E($P(IBXD,"^",4),1,43),?60,$$DAT1^IBOUTL($P($P(IBTNOD,"^",3),"."),2)
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)
IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ; 1-SEP-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, 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;")
PROCQ QUIT
+1 ;
ADD(IBTRN,TYPE) ; -- Add a new procedure
+1 ;
+2 NEW DTOUT,DUTOU,X,Y,DIC
+3 SET IBCNT=0
+4 IF '$GET(TYPE)
SET TYPE=""
NXT SET DIC("A")=$SELECT(IBCNT<1:"Select Procedure: ",1:"Next Procedure: ")
+1 SET DIC("S")="I '$P(^(0),U,9)"
+2 SET DIC="^ICD0("
SET DIC(0)="AEMQ"
SET X=""
+3 IF $GET(IBCNT)
WRITE !
DO ^DIC
KILL DIC
IF Y<0
GOTO ADDQ
+4 IF $DATA(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),+Y))
WRITE !!,*7,$PIECE(Y,"^",2)," is already a procedure.",!
+5 SET IBCNT=IBCNT+1
+6 SET IBADG=$$NEW(+Y,IBTRN,TYPE)
+7 IF IBADG
IF TYPE'=3
DO EDT(IBADG)
GOTO NXT
ADDQ QUIT
+1 ;
NEW(ICDI,IBTRN,TYPE) ; -- 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
+5 IF IBADG>0
LOCK +^IBT(356.91,IBADG)
SET $PIECE(^IBT(356.91,IBADG,0),"^",2,4)=$$DGPM^IBTRE3(IBTRN)_"^"_$PIECE($PIECE(^IBT(356,IBTRN,0),"^",6),".")
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
+3 SET DR=$GET(IBDR)
IF DR=""
SET DR=".03;"
+4 SET DA=IBADG
SET DIE="^IBT(356.91,"
+5 LOCK +^IBT(356.91,IBADG):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDTQ
+6 IF '$GET(^IBT(356.91,DA,0))
QUIT
+7 LOCK -^IBT(356.91,IBADG)
+8 DO ^DIE
EDTQ QUIT
+1 ;
SET(IBTRN) ; -- set array
+1 NEW IBDGPM,IBICD
+2 SET IBDGPM=$$DGPM^IBTRE3(IBTRN)
+3 SET (IBICD,IBCNT)=0
+4 FOR
SET IBICD=$ORDER(^IBT(356.91,"ADGPM",IBDGPM,IBICD))
IF 'IBICD
QUIT
SET IBDA=$ORDER(^(IBICD,0))
Begin DoDot:1
+5 SET IBCNT=IBCNT+1
+6 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
+4 WRITE !
+5 SET I=0
FOR
SET I=$ORDER(IBXY(I))
IF 'I
QUIT
SET IBXD=$GET(^ICD0(+$PIECE(IBXY(I),"^",2),0))
Begin DoDot:1
+6 SET IBTNOD=$GET(^IBT(356.91,+IBXY(I),0))
+7 WRITE !?2,I," ",$PIECE(IBXD,"^"),?15,$EXTRACT($PIECE(IBXD,"^",4),1,43),?60,$$DAT1^IBOUTL($PIECE($PIECE(IBTNOD,"^",3),"."),2)
End DoDot:1
+8 QUIT
+9 ;
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)
