IBTUTL1 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ;21-JUN-93
;;2.0;INTEGRATED BILLING;**13,223,249,292,384,517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;
OPT(DFN,IBETYP,IBTDT,ENCTR,IBRMARK,IBVSIT) ; -- add outpatient care entries
; -- input dfn := patient pointer to 2
; ibetyp := pointer to type entry in 356.6
; ibtdt := episode date
; enctr := pointer to opt. encounter file (optional)
; ibrmark := text of reason not billable (optional)
; ibvsit := pointer to visit file (optional)
;
N X,Y,DA,DR,DIE,DIC,IBSCRN
S IBSCRN=0
;Allow user inter-actions if not queued and IBTALK=1 or not exist.
I '$D(ZTQUEUED) D I IBSCRN G OPTSCRN
. I $D(IBTALK),'$G(IBTALK) Q
. I IBTDT<3060101 Q ;Don't use new code for claims prior to 1/1/2006
. S IBSCRN=1
I $G(IBETYP) S IBETYP=$O(^IBE(356.6,"AC",2,0))
I IBTDT<3060101 S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G OPTQ ;Prevent duplicate date/time claims prior to 1/1/2006
;Check for encounter already in claims tracking.
I $D(ENCTR),$D(^IBT(356,"AENC",+DFN,+ENCTR)) S IBTRN=$O(^IBT(356,"AENC",+DFN,+ENCTR,0)) G OPTQ
D ADDT^IBTUTL
S DA=IBTRN,DIE="^IBT(356,"
I IBTRN<1 G OPTQ
L +^IBT(356,+IBTRN):10 I '$T G OPTQ
S DR=".02////"_$G(DFN)_";.03////"_$G(IBVSIT)_";.04////"_$G(ENCTR)_";.06////"_+IBTDT_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
D ^DIE K DA,DR,DIE
L -^IBT(356,+IBTRN)
I IBETYP=2 S HCSRIEN=+$$FNDHCSR^IBTUTL(DFN,IBTDT) D:HCSRIEN HCSRCPY^IBTUTL(HCSRIEN,IBTRN,DFN,IBTDT)
OPTQ Q
;
REFILL(DFN,IBETYP,IBTDT,IBRXN,IBRXN1,IBRMARK,IBEABD,IBSCROI) ; -- add refill
; -- input dfn := patient pointer to 2
; ibetyp := pointer to type entry in 356.6
; ibtdt := episode date (refill date)
; ibrxn := pointer to 52
; ibrxn1 := refill multiple entry
; ibrmark := non billable reason if unsure
; ibeabd := optional, can specify an earliest auto bill date
; ibscroi := special consent roi
;
N X,Y,DA,DR,DIE,DIC
;S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G REFILLQ
S X=$O(^IBT(356,"ARXFL",IBRXN,IBRXN1,0)) I X S IBTRN=X G REFILLQ
D ADDT^IBTUTL
I IBTRN<1 G REFILLQ
S DA=IBTRN,DIE="^IBT(356,"
L +^IBT(356,+IBTRN):10 I '$T G REFILLQ
S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.08////"_IBRXN_";.1////"_IBRXN1_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_$S($G(IBDUZ):IBDUZ,1:DUZ)_";.17////"_$S($G(IBEABD):IBEABD,1:$$EABD^IBTUTL(IBETYP))
I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
I $G(IBSCROI)'="" S DR=DR_";.31////"_IBSCROI ;IB*2*384
D ^DIE K DA,DR,DIE
L -^IBT(356,+IBTRN)
REFILLQ Q
;
PRO(DFN,IBTDT,IBPRO,IBRMARK) ; -- add prosthetic entries
; -- input dfn := patient pointer to 2
; ibetyp := pointer to type entry in 356.6
; ibtdt := episode date
;
N X,Y,DA,DR,DIE,DIC,IBETYP
;S IBETYP=$O(^IBE(356.6,"ACODE",4,0))
S IBETYP=$O(^IBE(356.6,"AC",3,0)) ;prosthetics type
S X=$O(^IBT(356,"APRO",IBPRO,0)) I X S IBTRN=X G PROQ
D ADDT^IBTUTL
I IBTRN<1 G PROQ
S DA=IBTRN,DIE="^IBT(356,"
L +^IBT(356,+IBTRN):10 I '$T G PROQ
S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.09////"_IBPRO_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
D ^DIE K DA,DR,DIE
L -^IBT(356,+IBTRN)
PROQ Q
;
PT(DFN) ; -- format patient name - last 4 for output
S Y="" I '$G(DFN) G PTQ
I '$D(VA("PID")) D PID^VADPT
S Y=$E($P($G(^DPT(DFN,0)),"^"),1,20)_" "_$E($G(^(0)),1)_VA("BID")
PTQ Q Y
;
PRODATA(IBDA) ; -- return data from prosthetics file
N IBDA0,DA,DIC,DIE,DR
K IBRMPR ; only one array at a time
I '$G(IBDA) G PRODAQ
S IBDA0=$G(^RMPR(660,+IBDA,0))
G:IBDA0="" PRODAQ
DIQ S DIC="^RMPR(660,",DR=".01;1:5;7;10;12:17;24"
S DIQ="IBRMPR",DIQ(0)="E",DA=IBDA
D EN^DIQ1
PRODAQ Q
;
OPTSCRN ; -- add outpatient care entries with user feedback
; called from OPT^IBTUTL1 which has following inputs
; -- input dfn := patient pointer to 2
; ibetyp := pointer to type entry in 356.6
; ibtdt := episode date
; enctr := pointer to opt. encounter file (optional)
; ibrmark := text of reason not billable (optional)
; ibvsit := pointer to visit file (optional)
;
N CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IB3560,IBACT,IBDATE,IBENC,IBETYPNM
N IBID,IBPATNM,IBQUIT,LINE,TEMP,TMP
;If encounter passed in already exists in claims Tracking, remove it.
I $D(ENCTR),$D(^IBT(356,"AENC",+DFN,+ENCTR)) S ENCTR=""
I $G(IBETYP) S IBETYP=$O(^IBE(356.6,"AC",2,0))
S IBQUIT=0
I $O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) D I X S IBTRN=X G OPTSCRNQ
. S (CNT,LINE)=1,(TEMP,TMP,X)=""
. S Y=IBTDT D DD^%DT S IBDATE=$E(Y_" ",1,18) S Y=""
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. S TMP("DIMSG",LINE)="There are match(es) for the episode date you have entered:",LINE=LINE+1
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. S TMP("DIMSG",LINE)=" EPISODE DATE PATIENT NAME CT ID TYPE ENCOUNTER ACTIVE",LINE=LINE+1
. S TMP("DIMSG",LINE)=" ------------ ------------ ----- ---- --------- ------",LINE=LINE+1
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. F S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,X)) Q:X="" D
.. S IB3560=$G(^IBT(356,X,0)) I IB3560="" Q
.. S IBID=$P($G(IB3560),U,1) S IBID=$S(IBID="":"ID_UNKNOWN",1:$E(IBID_" ",1,10))
.. S IBPATNM=$P($G(^DPT(DFN,0)),U,1) S IBPATNM=$S(IBPATNM="":"PATIENT_UNKNOWN",1:$E(IBPATNM_" ",1,15))
.. S IBENC=$P($G(IB3560),U,4) S IBENC=$S(IBENC="":"NONE ",1:$E(IBENC_" ",1,10))
.. S IBACT=$S($P($G(IB3560),U,20)=1:"YES",1:"NO ")
.. S IBETYPNM=$P($G(^IBE(356.6,IBETYP,0)),U,2) S IBETYPNM=$S(IBETYPNM="":"NONE ",1:$E(IBETYPNM_" ",1,8))
.. S TMP("DIMSG",LINE)=$E(CNT_" ",1,3)_IBDATE_" "_IBPATNM_" "_IBID_" "_IBETYPNM_" "_IBENC_" "_IBACT
.. S TEMP(CNT)=X_"^"_$TR(IBENC," ",""),CNT=CNT+1
.. S LINE=LINE+1
. I CNT>0 D
.. S TMP("DIMSG",LINE+1)=$E(CNT_" ",1,3)_"*** CREATE A NEW CLAIMS TRACKING ENTRY ***"
.. D MSG^DIALOG("WM",,,,"TMP")
.. S DIR(0)="NA^1:"_CNT_":0"
.. S DIR("A")="Select a Claims Tracking entry: "
.. S DIR("?",1)="Choose a Claims Tracking entry from the previous list to continue processing."
.. S DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
.. D ^DIR
.. I ($G(DTOUT))!($G(DUOUT))!($G(DIRUT))!($G(DIROUT)) S IBQUIT=1
.. I Y>0 S X=+$G(TEMP(Y)) I +$P($G(TEMP(Y)),U,2)>0 S ENCTR=$P($G(TEMP(Y)),U,2)
I IBQUIT Q
I '$G(ENCTR) D
. N CNT,DIR,IBDATA,IBDATA1,IBDATA2,IBERR,IBMSG,IBSCRN,IBTMP,LINE,TMP,X
. N DIOUT,DIROUT,DTOUT,DUOUT
. S X(1)=IBTDT
. S IBSCRN="I $P($G(^(0)),U,2)="_DFN
. S IBMSG="IBTMP(""ENC"")"
. S IBERR="IBTMP(""ERR"")"
. D FIND^DIC(409.68,,,"PQX",.X,,"B",IBSCRN,,IBMSG,IBERR)
. I +IBTMP("ENC","DILIST",0)=0 S ENCTR="" Q
. S CNT=+IBTMP("ENC","DILIST",0)+1
. S (LINE,X)=0
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. S TMP("DIMSG",LINE)="There are encounters for the episode date you have selected:",LINE=LINE+1
. S TMP("DIMSG",LINE)=" ",LINE=LINE+1
. F S X=$O(IBTMP("ENC","DILIST",X)) Q:X="" D
.. S LINE=LINE+1
.. S IBDATA1=$P($G(IBTMP("ENC","DILIST",X,0)),"^"_IBTDT,1)
.. S IBDATA2=$P($G(IBTMP("ENC","DILIST",X,0)),"^"_IBTDT,2)
.. S IBDATA=$TR(IBDATA1_IBDATA2,"^"," ")
.. S TMP("DIMSG",LINE)=$E(X_" ",1,4)_IBDATA
. S TMP("DIMSG",LINE+1)=$E(+IBTMP("ENC","DILIST",0)+1_" ",1,4)_"*** CREATE A NEW CLAIMS TRACKING ENTRY WITHOUT AN ENCOUNTER ***"
. D MSG^DIALOG("WM",,,,"TMP")
. S DIR(0)="NA^1:"_CNT_":0"
. S DIR("A")="Select an Encounter for the Claims Tracking entry: "
. S DIR("?",1)="Choose an Encounter from the previous list to continue processing."
. S DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
. D ^DIR
. I ($G(DTOUT))!($G(DUOUT))!($G(DIRUT))!($G(DIROUT)) S IBQUIT=1
. I +$G(Y)<1 Q
. S ENCTR=+$G(IBTMP("ENC","DILIST",+Y,0)) I 'ENCTR Q
. I $D(^IBT(356,"AENC",+DFN,ENCTR)) S IBTRN=$O(^IBT(356,"AENC",+DFN,ENCTR,0)) Q
I IBQUIT Q
G:$G(IBTRN)'="" OPTSCRNQ
D ADDT^IBTUTL
S DA=IBTRN,DIE="^IBT(356,"
I IBTRN<1 G OPTSCRNQ
L +^IBT(356,+IBTRN):10 I '$T G OPTSCRNQ
S DR=".02////"_$G(DFN)_";.03////"_$G(IBVSIT)_";.04////"_$G(ENCTR)_";.06////"_+IBTDT_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
I $G(IBRMARK)'="" S DR=DR_";.19///"_IBRMARK
D ^DIE K DA,DR,DIE
L -^IBT(356,+IBTRN)
OPTSCRNQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTUTL1 8884 printed Dec 13, 2024@02:29:14 Page 2
IBTUTL1 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ;21-JUN-93
+1 ;;2.0;INTEGRATED BILLING;**13,223,249,292,384,517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
OPT(DFN,IBETYP,IBTDT,ENCTR,IBRMARK,IBVSIT) ; -- add outpatient care entries
+1 ; -- input dfn := patient pointer to 2
+2 ; ibetyp := pointer to type entry in 356.6
+3 ; ibtdt := episode date
+4 ; enctr := pointer to opt. encounter file (optional)
+5 ; ibrmark := text of reason not billable (optional)
+6 ; ibvsit := pointer to visit file (optional)
+7 ;
+8 NEW X,Y,DA,DR,DIE,DIC,IBSCRN
+9 SET IBSCRN=0
+10 ;Allow user inter-actions if not queued and IBTALK=1 or not exist.
+11 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+12 IF $DATA(IBTALK)
IF '$GET(IBTALK)
QUIT
+13 ;Don't use new code for claims prior to 1/1/2006
IF IBTDT<3060101
QUIT
+14 SET IBSCRN=1
End DoDot:1
IF IBSCRN
GOTO OPTSCRN
+15 IF $GET(IBETYP)
SET IBETYP=$ORDER(^IBE(356.6,"AC",2,0))
+16 ;Prevent duplicate date/time claims prior to 1/1/2006
IF IBTDT<3060101
SET X=$ORDER(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0))
IF X
SET IBTRN=X
GOTO OPTQ
+17 ;Check for encounter already in claims tracking.
+18 IF $DATA(ENCTR)
IF $DATA(^IBT(356,"AENC",+DFN,+ENCTR))
SET IBTRN=$ORDER(^IBT(356,"AENC",+DFN,+ENCTR,0))
GOTO OPTQ
+19 DO ADDT^IBTUTL
+20 SET DA=IBTRN
SET DIE="^IBT(356,"
+21 IF IBTRN<1
GOTO OPTQ
+22 LOCK +^IBT(356,+IBTRN):10
IF '$TEST
GOTO OPTQ
+23 SET DR=".02////"_$GET(DFN)_";.03////"_$GET(IBVSIT)_";.04////"_$GET(ENCTR)_";.06////"_+IBTDT_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
+24 IF $GET(IBRMARK)'=""
SET DR=DR_";.19///"_IBRMARK
+25 DO ^DIE
KILL DA,DR,DIE
+26 LOCK -^IBT(356,+IBTRN)
+27 IF IBETYP=2
SET HCSRIEN=+$$FNDHCSR^IBTUTL(DFN,IBTDT)
if HCSRIEN
DO HCSRCPY^IBTUTL(HCSRIEN,IBTRN,DFN,IBTDT)
OPTQ QUIT
+1 ;
REFILL(DFN,IBETYP,IBTDT,IBRXN,IBRXN1,IBRMARK,IBEABD,IBSCROI) ; -- add refill
+1 ; -- input dfn := patient pointer to 2
+2 ; ibetyp := pointer to type entry in 356.6
+3 ; ibtdt := episode date (refill date)
+4 ; ibrxn := pointer to 52
+5 ; ibrxn1 := refill multiple entry
+6 ; ibrmark := non billable reason if unsure
+7 ; ibeabd := optional, can specify an earliest auto bill date
+8 ; ibscroi := special consent roi
+9 ;
+10 NEW X,Y,DA,DR,DIE,DIC
+11 ;S X=$O(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0)) I X S IBTRN=X G REFILLQ
+12 SET X=$ORDER(^IBT(356,"ARXFL",IBRXN,IBRXN1,0))
IF X
SET IBTRN=X
GOTO REFILLQ
+13 DO ADDT^IBTUTL
+14 IF IBTRN<1
GOTO REFILLQ
+15 SET DA=IBTRN
SET DIE="^IBT(356,"
+16 LOCK +^IBT(356,+IBTRN):10
IF '$TEST
GOTO REFILLQ
+17 SET DR=".02////"_$GET(DFN)_";.06////"_+IBTDT_";.08////"_IBRXN_";.1////"_IBRXN1_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_$SELECT($GET(IBDUZ):IBDUZ,1:DUZ)_";.17////"_...
... $SELECT($GET(IBEABD):IBEABD,1:$$EABD^IBTUTL(IBETYP))
+18 IF $GET(IBRMARK)'=""
SET DR=DR_";.19///"_IBRMARK
+19 ;IB*2*384
IF $GET(IBSCROI)'=""
SET DR=DR_";.31////"_IBSCROI
+20 DO ^DIE
KILL DA,DR,DIE
+21 LOCK -^IBT(356,+IBTRN)
REFILLQ QUIT
+1 ;
PRO(DFN,IBTDT,IBPRO,IBRMARK) ; -- add prosthetic entries
+1 ; -- input dfn := patient pointer to 2
+2 ; ibetyp := pointer to type entry in 356.6
+3 ; ibtdt := episode date
+4 ;
+5 NEW X,Y,DA,DR,DIE,DIC,IBETYP
+6 ;S IBETYP=$O(^IBE(356.6,"ACODE",4,0))
+7 ;prosthetics type
SET IBETYP=$ORDER(^IBE(356.6,"AC",3,0))
+8 SET X=$ORDER(^IBT(356,"APRO",IBPRO,0))
IF X
SET IBTRN=X
GOTO PROQ
+9 DO ADDT^IBTUTL
+10 IF IBTRN<1
GOTO PROQ
+11 SET DA=IBTRN
SET DIE="^IBT(356,"
+12 LOCK +^IBT(356,+IBTRN):10
IF '$TEST
GOTO PROQ
+13 SET DR=".02////"_$GET(DFN)_";.06////"_+IBTDT_";.09////"_IBPRO_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
+14 IF $GET(IBRMARK)'=""
SET DR=DR_";.19///"_IBRMARK
+15 DO ^DIE
KILL DA,DR,DIE
+16 LOCK -^IBT(356,+IBTRN)
PROQ QUIT
+1 ;
PT(DFN) ; -- format patient name - last 4 for output
+1 SET Y=""
IF '$GET(DFN)
GOTO PTQ
+2 IF '$DATA(VA("PID"))
DO PID^VADPT
+3 SET Y=$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^"),1,20)_" "_$EXTRACT($GET(^(0)),1)_VA("BID")
PTQ QUIT Y
+1 ;
PRODATA(IBDA) ; -- return data from prosthetics file
+1 NEW IBDA0,DA,DIC,DIE,DR
+2 ; only one array at a time
KILL IBRMPR
+3 IF '$GET(IBDA)
GOTO PRODAQ
+4 SET IBDA0=$GET(^RMPR(660,+IBDA,0))
+5 if IBDA0=""
GOTO PRODAQ
DIQ SET DIC="^RMPR(660,"
SET DR=".01;1:5;7;10;12:17;24"
+1 SET DIQ="IBRMPR"
SET DIQ(0)="E"
SET DA=IBDA
+2 DO EN^DIQ1
PRODAQ QUIT
+1 ;
OPTSCRN ; -- add outpatient care entries with user feedback
+1 ; called from OPT^IBTUTL1 which has following inputs
+2 ; -- input dfn := patient pointer to 2
+3 ; ibetyp := pointer to type entry in 356.6
+4 ; ibtdt := episode date
+5 ; enctr := pointer to opt. encounter file (optional)
+6 ; ibrmark := text of reason not billable (optional)
+7 ; ibvsit := pointer to visit file (optional)
+8 ;
+9 NEW CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IB3560,IBACT,IBDATE,IBENC,IBETYPNM
+10 NEW IBID,IBPATNM,IBQUIT,LINE,TEMP,TMP
+11 ;If encounter passed in already exists in claims Tracking, remove it.
+12 IF $DATA(ENCTR)
IF $DATA(^IBT(356,"AENC",+DFN,+ENCTR))
SET ENCTR=""
+13 IF $GET(IBETYP)
SET IBETYP=$ORDER(^IBE(356.6,"AC",2,0))
+14 SET IBQUIT=0
+15 IF $ORDER(^IBT(356,"APTY",DFN,IBETYP,IBTDT,0))
Begin DoDot:1
+16 SET (CNT,LINE)=1
SET (TEMP,TMP,X)=""
+17 SET Y=IBTDT
DO DD^%DT
SET IBDATE=$EXTRACT(Y_" ",1,18)
SET Y=""
+18 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+19 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+20 SET TMP("DIMSG",LINE)="There are match(es) for the episode date you have entered:"
SET LINE=LINE+1
+21 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+22 SET TMP("DIMSG",LINE)=" EPISODE DATE PATIENT NAME CT ID TYPE ENCOUNTER ACTIVE"
SET LINE=LINE+1
+23 SET TMP("DIMSG",LINE)=" ------------ ------------ ----- ---- --------- ------"
SET LINE=LINE+1
+24 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+25 FOR
SET X=$ORDER(^IBT(356,"APTY",DFN,IBETYP,IBTDT,X))
if X=""
QUIT
Begin DoDot:2
+26 SET IB3560=$GET(^IBT(356,X,0))
IF IB3560=""
QUIT
+27 SET IBID=$PIECE($GET(IB3560),U,1)
SET IBID=$SELECT(IBID="":"ID_UNKNOWN",1:$EXTRACT(IBID_" ",1,10))
+28 SET IBPATNM=$PIECE($GET(^DPT(DFN,0)),U,1)
SET IBPATNM=$SELECT(IBPATNM="":"PATIENT_UNKNOWN",1:$EXTRACT(IBPATNM_" ",1,15))
+29 SET IBENC=$PIECE($GET(IB3560),U,4)
SET IBENC=$SELECT(IBENC="":"NONE ",1:$EXTRACT(IBENC_" ",1,10))
+30 SET IBACT=$SELECT($PIECE($GET(IB3560),U,20)=1:"YES",1:"NO ")
+31 SET IBETYPNM=$PIECE($GET(^IBE(356.6,IBETYP,0)),U,2)
SET IBETYPNM=$SELECT(IBETYPNM="":"NONE ",1:$EXTRACT(IBETYPNM_" ",1,8))
+32 SET TMP("DIMSG",LINE)=$EXTRACT(CNT_" ",1,3)_IBDATE_" "_IBPATNM_" "_IBID_" "_IBETYPNM_" "_IBENC_" "_IBACT
+33 SET TEMP(CNT)=X_"^"_$TRANSLATE(IBENC," ","")
SET CNT=CNT+1
+34 SET LINE=LINE+1
End DoDot:2
+35 IF CNT>0
Begin DoDot:2
+36 SET TMP("DIMSG",LINE+1)=$EXTRACT(CNT_" ",1,3)_"*** CREATE A NEW CLAIMS TRACKING ENTRY ***"
+37 DO MSG^DIALOG("WM",,,,"TMP")
+38 SET DIR(0)="NA^1:"_CNT_":0"
+39 SET DIR("A")="Select a Claims Tracking entry: "
+40 SET DIR("?",1)="Choose a Claims Tracking entry from the previous list to continue processing."
+41 SET DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
+42 DO ^DIR
+43 IF ($GET(DTOUT))!($GET(DUOUT))!($GET(DIRUT))!($GET(DIROUT))
SET IBQUIT=1
+44 IF Y>0
SET X=+$GET(TEMP(Y))
IF +$PIECE($GET(TEMP(Y)),U,2)>0
SET ENCTR=$PIECE($GET(TEMP(Y)),U,2)
End DoDot:2
End DoDot:1
IF X
SET IBTRN=X
GOTO OPTSCRNQ
+45 IF IBQUIT
QUIT
+46 IF '$GET(ENCTR)
Begin DoDot:1
+47 NEW CNT,DIR,IBDATA,IBDATA1,IBDATA2,IBERR,IBMSG,IBSCRN,IBTMP,LINE,TMP,X
+48 NEW DIOUT,DIROUT,DTOUT,DUOUT
+49 SET X(1)=IBTDT
+50 SET IBSCRN="I $P($G(^(0)),U,2)="_DFN
+51 SET IBMSG="IBTMP(""ENC"")"
+52 SET IBERR="IBTMP(""ERR"")"
+53 DO FIND^DIC(409.68,,,"PQX",.X,,"B",IBSCRN,,IBMSG,IBERR)
+54 IF +IBTMP("ENC","DILIST",0)=0
SET ENCTR=""
QUIT
+55 SET CNT=+IBTMP("ENC","DILIST",0)+1
+56 SET (LINE,X)=0
+57 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+58 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+59 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+60 SET TMP("DIMSG",LINE)="There are encounters for the episode date you have selected:"
SET LINE=LINE+1
+61 SET TMP("DIMSG",LINE)=" "
SET LINE=LINE+1
+62 FOR
SET X=$ORDER(IBTMP("ENC","DILIST",X))
if X=""
QUIT
Begin DoDot:2
+63 SET LINE=LINE+1
+64 SET IBDATA1=$PIECE($GET(IBTMP("ENC","DILIST",X,0)),"^"_IBTDT,1)
+65 SET IBDATA2=$PIECE($GET(IBTMP("ENC","DILIST",X,0)),"^"_IBTDT,2)
+66 SET IBDATA=$TRANSLATE(IBDATA1_IBDATA2,"^"," ")
+67 SET TMP("DIMSG",LINE)=$EXTRACT(X_" ",1,4)_IBDATA
End DoDot:2
+68 SET TMP("DIMSG",LINE+1)=$EXTRACT(+IBTMP("ENC","DILIST",0)+1_" ",1,4)_"*** CREATE A NEW CLAIMS TRACKING ENTRY WITHOUT AN ENCOUNTER ***"
+69 DO MSG^DIALOG("WM",,,,"TMP")
+70 SET DIR(0)="NA^1:"_CNT_":0"
+71 SET DIR("A")="Select an Encounter for the Claims Tracking entry: "
+72 SET DIR("?",1)="Choose an Encounter from the previous list to continue processing."
+73 SET DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
+74 DO ^DIR
+75 IF ($GET(DTOUT))!($GET(DUOUT))!($GET(DIRUT))!($GET(DIROUT))
SET IBQUIT=1
+76 IF +$GET(Y)<1
QUIT
+77 SET ENCTR=+$GET(IBTMP("ENC","DILIST",+Y,0))
IF 'ENCTR
QUIT
+78 IF $DATA(^IBT(356,"AENC",+DFN,ENCTR))
SET IBTRN=$ORDER(^IBT(356,"AENC",+DFN,ENCTR,0))
QUIT
End DoDot:1
+79 IF IBQUIT
QUIT
+80 if $GET(IBTRN)'=""
GOTO OPTSCRNQ
+81 DO ADDT^IBTUTL
+82 SET DA=IBTRN
SET DIE="^IBT(356,"
+83 IF IBTRN<1
GOTO OPTSCRNQ
+84 LOCK +^IBT(356,+IBTRN):10
IF '$TEST
GOTO OPTSCRNQ
+85 SET DR=".02////"_$GET(DFN)_";.03////"_$GET(IBVSIT)_";.04////"_$GET(ENCTR)_";.06////"_+IBTDT_";.18////"_IBETYP_";.2////1;.24////"_$$INSURED^IBCNS1(DFN)_";1.01///NOW;1.02////"_DUZ_";.17////"_$$EABD^IBTUTL(IBETYP)
+86 IF $GET(IBRMARK)'=""
SET DR=DR_";.19///"_IBRMARK
+87 DO ^DIE
KILL DA,DR,DIE
+88 LOCK -^IBT(356,+IBTRN)
OPTSCRNQ QUIT
