IBCSC10B ;BP/YMG - ADD/ENTER PATIENT REASON FOR VISIT DATA ;10/15/2008
;;2.0;INTEGRATED BILLING;**432,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
; routines and created a new billing screen 8 routine IBCSC8.
;
EN ; entry point
N DATE,DATE1,DFN,I,IBDX,IBLIST,LOC,PRV0,PRVIEN,PRVS,SCREEN,TCNT,TMP,VCNT,VISITS
D:$$CHKPRV<3 DELALL(IBIFN)
; only try to fetch PRVs if Quadramed file (19640.11) exists
I $D(^DSIPPRV) D
.S DFN=$P(^DGCR(399,IBIFN,0),U,2)
.; try to get all visits for OP Visit dates on the claim
.;
.; use only the date portion of date&time field in VISIT file for screening
.; if OP Visit field contains only a month, only compare month and year
.S SCREEN="N Z S Z=$P($P(^(0),U),""."") S:'+$E(DATE,6,7) Z=$E(Z,1,5) I Z=DATE"
.S DATE=0,VCNT=1 F S DATE=$O(^DGCR(399,IBIFN,"OP",DATE)) Q:'DATE D
..D FIND^DIC(9000010,,"@;.01I","QPX",DFN,,"C",SCREEN,,"TMP") Q:'$P(TMP("DILIST",0),U)
..S TCNT=0 F S TCNT=$O(TMP("DILIST",TCNT)) Q:'TCNT S VISITS(VCNT)=$P(TMP("DILIST",TCNT,0),U),VCNT=VCNT+1
..Q
.I '$D(VISITS) D
..; couldn't find anything for OP Visit dates (or there are no OP Visit dates on the claim)
..; try to use Statement Covers From and Statement Covers To fields instead
..S DATE=$P($G(^DGCR(399,IBIFN,"U")),U) Q:'DATE ;
..S DATE1=$P($G(^DGCR(399,IBIFN,"U")),U,2) Q:'DATE1 ;
..S SCREEN="N Z S Z=$P($P(^(0),U),""."") I Z>=DATE&(Z<=DATE1)"
..D FIND^DIC(9000010,,"@;.01I","QPX",DFN,,"C",SCREEN,,"TMP") Q:'$P(TMP("DILIST",0),U)
..S TCNT=0,VCNT=1 F S TCNT=$O(TMP("DILIST",TCNT)) Q:'TCNT S VISITS(VCNT)=$P(TMP("DILIST",TCNT,0),U),VCNT=VCNT+1
..Q
.I $D(VISITS) D
..; we have found some visits, try to fetch corresponding PRVs from file 19640.11 into PRVS array
..; PRVS node structure: PRV dx ien ^ hospital location ^ visit date&time
..S TCNT=1,VCNT=0 F S VCNT=$O(VISITS(VCNT)) Q:'VCNT D
...S PRVIEN=$O(^DSIPPRV("B",VISITS(VCNT),"")) Q:'PRVIEN
...S PRV0=$G(^DSIPPRV(PRVIEN,0))
...S LOC=$$GET1^DIQ(9000010,VISITS(VCNT),.22)
...S DATE=$$GET1^DIQ(9000010,VISITS(VCNT),.01)
...F I=2:1:4 I $P(PRV0,U,I)'="" S PRVS(TCNT)=$P(PRV0,U,I)_U_LOC_U_DATE,TCNT=TCNT+1
...Q
..Q
.Q
D DISP D:+$G(TCNT)>0 NEWDX(TCNT-1) I $D(IBLIST) D ADDNEW
D DISPEX(IBIFN)
D CLEAN^DILF
EN1 ;
S IBDX=$$ASKDX I +IBDX>0 D ADD($P(IBDX,U)),EDIT(+IBDX) G EN1
Q
;
DISP ; display PRV diagnoses
N CNT,DXCODE,I,IBDX,PRV
W @IOF,!,"===================Pt. Reason for Visit Diagnosis Screen ====================",!
I '$D(PRVS) W !,?13,"No available Pt. Reason for Visit Diagnoses found." Q
S CNT=0 F S CNT=$O(PRVS(CNT)) Q:'CNT D
.S IBDX=$$ICD9^IBACSV($P(PRVS(CNT),U),$$BDATE^IBACSV(IBIFN)),DXCODE=$P(IBDX,U)
.F I=8:1:10 S PRV=$P($G(^DGCR(399,IBIFN,"U3")),U,I) I PRV=+PRVS(CNT) S DXCODE="*"_DXCODE Q
.W !,$J(CNT,2),")",?4,DXCODE,?15,$E($P(IBDX,U,3),1,30),?46,$E($P(PRVS(CNT),U,2),1,14),?62,$P(PRVS(CNT),U,3)
.Q
Q
;
DISPEX(IBIFN) ; display existing PRV diagnoses for a bill
N I,IBDX,IBDXDT
W !!,?5,"------ Existing Pt. Reason for Visit Diagnoses for Bill -------",!
F I=8:1:10 S IBDX=$P($G(^DGCR(399,IBIFN,"U3")),U,I) I IBDX'="" D
.S IBDXDT=$$ICD9^IBACSV(IBDX,$$BDATE^IBACSV(IBIFN))
.W !,?5,$P(IBDXDT,U),?17,$P(IBDXDT,U,3)
;
W:$G(IBDXDT)="" !,?13,"No existing Pt. Reason for Visit Diagnoses found."
W !
Q
;
CHKPRV() ; check how many PRVs are not populated (out of 3)
N CNT,I
S CNT=3 F I=8:1:10 I $P($G(^DGCR(399,IBIFN,"U3")),U,I)'="" S CNT=CNT-1
Q CNT
;
PRVFLD(DXIEN) ; returns the field number that contains DXIEN
; if DXIEN="", returns the first empty PRV field number
; if no match found (or no empty fields), returns 0
N I,FLD
S FLD=0 F I=8:1:10 I $P($G(^DGCR(399,IBIFN,"U3")),U,I)=DXIEN S FLD=I+241 Q
Q FLD
;
ERR ; display error message
W !,?6,"You may add a maximum of 3 PRV diagnoses to a claim."
Q
;
NEWDX(IBX) ; select PRV diagnosis to add to bill
; IBX - max. number of PRV diagnoses available
N X,Y,DIR,DIRUT
Q:'IBX!('$$CHKPRV) ;
W !
NEWDX1 S DIR("?",1)="Enter the number preceding the PRV diagnosis you want added to the bill.",DIR("?")="Multiple entries may be added separated by commas or ranges separated by a dash."
S DIR("A")="Select Pt. Reason for Visit Diagnosis to add to bill"
S DIR(0)="LO^1:"_+IBX D ^DIR K DIR G:'Y!$D(DIRUT) NEWDXE
S IBLIST=Y
S DIR("A")="You have selected "_IBLIST_" to be added to the bill. Is this correct",DIR("B")="YES"
S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST G NEWDXE
I 'Y G NEWDX1
I $L(IBLIST,",")-1>$$CHKPRV D ERR G NEWDX1
NEWDXE Q
;
ADD(DXIEN) ; add single PRV diagnosis with file 80 ien DXIEN to the bill
Q:'DXIEN!$$PRVFLD(DXIEN) ; quit if no dx ien or if such PRV already exists
N FLD
; if there are already 3 PRVs on the claim, complain and bail out
I '$$CHKPRV D ERR Q
S FLD=$$PRVFLD("") I FLD S DIE="^DGCR(399,",DA=IBIFN,DR=FLD_"////"_DXIEN D ^DIE K DA,DIE
Q
;
ADDNEW ; add selected PRV diagnoses to the bill
Q:'$D(PRVS)
N I,IBX
F I=1:1 S IBX=$P(IBLIST,",",I) Q:'IBX I $D(PRVS(IBX)) D ADD(+PRVS(IBX))
Q
;
ASKDX() ; enter extra PRV diagnosis
; returns dx ien in file 80 ^ dx code
N X,Y,IBDATE,IBDTTX,ICDVDT
S IBDATE=$$BDATE^IBACSV(IBIFN),ICDVDT=IBDATE
S IBDTTX=$$DAT1^IBOUTL(IBDATE)
AD ;
S DIR("?")="Enter a diagnosis for this bill. Only diagnosis codes active on "_IBDTTX_" are allowed."
S DIR("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE) ; inactive allowed but either ICD-9 or ICD-10 *461
S DIR(0)="PO^80:EAMQI",DIR("A")="Enter Pt. Reason for Visit Diagnosis"
D ^DIR K DIR
I Y>0,'$$PRVFLD(+Y),'$$ICD9ACT^IBACSV(+Y,IBDATE) D G AD
. W !!,*7,"The Diagnosis code is inactive for the date of service ("_IBDTTX_").",!
Q Y
;
EDIT(DXIEN) ; edit/delete PRV diagnosis
N IBU3,FLD,PRV2,PRV3
Q:'DXIEN S FLD=$$PRVFLD(DXIEN) I FLD S DIE="^DGCR(399,",DA=IBIFN,DR=FLD D ^DIE K DIE,DR,DA
; if PRV was deleted, rearrange PRVs to maintain their order of entry
S IBU3=$G(^DGCR(399,IBIFN,"U3")) I $P(IBU3,U,FLD-241)="" D
.; PRV(1) was deleted, PRV(2) is not empty
.I FLD=249 S PRV2=$P(IBU3,U,9) S:PRV2'="" PRV3=$P(IBU3,U,10),DR="249////"_PRV2_";"_$S(PRV3'="":"250////"_PRV3_";251///@",1:"250///@")
.; PRV(2) was deleted, PRV(3) is not empty
.I FLD=250 S PRV3=$P(IBU3,U,10) I PRV3'="" S DR="250////"_PRV3_";251///@"
.; if PRV(3) is deleted, no rearrangements are necessary
.Q
I $G(DR)'="" S DIE="^DGCR(399,",DA=IBIFN D ^DIE K DIE,DR,DA
Q
;
DELALL(IBIFN) ; ask/delete all PRV diagnoses on the bill
N DIE,DA,DR,DIR,DIRUT,DUOUT,DTOUT,X,Y W !
S DIR("?")="Enter Yes to delete all PRV diagnoses currently defined for a bill.",DIR("??")="^D DISPEX^IBCSC10B("_IBIFN_")"
S DIR("A")="Delete all Patient Reason for Visit diagnoses on bill"
S DIR(0)="YO",DIR("B")="NO" D ^DIR K DIR Q:Y'=1
;
S DIE="^DGCR(399,",DA=IBIFN,DR="249///@;250///@;251///@" D ^DIE
W " .... deleted"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC10B 7012 printed Apr 09, 2024@21:07:38 Page 2
IBCSC10B ;BP/YMG - ADD/ENTER PATIENT REASON FOR VISIT DATA ;10/15/2008
+1 ;;2.0;INTEGRATED BILLING;**432,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
+5 ; routines and created a new billing screen 8 routine IBCSC8.
+6 ;
EN ; entry point
+1 NEW DATE,DATE1,DFN,I,IBDX,IBLIST,LOC,PRV0,PRVIEN,PRVS,SCREEN,TCNT,TMP,VCNT,VISITS
+2 if $$CHKPRV<3
DO DELALL(IBIFN)
+3 ; only try to fetch PRVs if Quadramed file (19640.11) exists
+4 IF $DATA(^DSIPPRV)
Begin DoDot:1
+5 SET DFN=$PIECE(^DGCR(399,IBIFN,0),U,2)
+6 ; try to get all visits for OP Visit dates on the claim
+7 ;
+8 ; use only the date portion of date&time field in VISIT file for screening
+9 ; if OP Visit field contains only a month, only compare month and year
+10 SET SCREEN="N Z S Z=$P($P(^(0),U),""."") S:'+$E(DATE,6,7) Z=$E(Z,1,5) I Z=DATE"
+11 SET DATE=0
SET VCNT=1
FOR
SET DATE=$ORDER(^DGCR(399,IBIFN,"OP",DATE))
if 'DATE
QUIT
Begin DoDot:2
+12 DO FIND^DIC(9000010,,"@;.01I","QPX",DFN,,"C",SCREEN,,"TMP")
if '$PIECE(TMP("DILIST",0),U)
QUIT
+13 SET TCNT=0
FOR
SET TCNT=$ORDER(TMP("DILIST",TCNT))
if 'TCNT
QUIT
SET VISITS(VCNT)=$PIECE(TMP("DILIST",TCNT,0),U)
SET VCNT=VCNT+1
+14 QUIT
End DoDot:2
+15 IF '$DATA(VISITS)
Begin DoDot:2
+16 ; couldn't find anything for OP Visit dates (or there are no OP Visit dates on the claim)
+17 ; try to use Statement Covers From and Statement Covers To fields instead
+18 ;
SET DATE=$PIECE($GET(^DGCR(399,IBIFN,"U")),U)
if 'DATE
QUIT
+19 ;
SET DATE1=$PIECE($GET(^DGCR(399,IBIFN,"U")),U,2)
if 'DATE1
QUIT
+20 SET SCREEN="N Z S Z=$P($P(^(0),U),""."") I Z>=DATE&(Z<=DATE1)"
+21 DO FIND^DIC(9000010,,"@;.01I","QPX",DFN,,"C",SCREEN,,"TMP")
if '$PIECE(TMP("DILIST",0),U)
QUIT
+22 SET TCNT=0
SET VCNT=1
FOR
SET TCNT=$ORDER(TMP("DILIST",TCNT))
if 'TCNT
QUIT
SET VISITS(VCNT)=$PIECE(TMP("DILIST",TCNT,0),U)
SET VCNT=VCNT+1
+23 QUIT
End DoDot:2
+24 IF $DATA(VISITS)
Begin DoDot:2
+25 ; we have found some visits, try to fetch corresponding PRVs from file 19640.11 into PRVS array
+26 ; PRVS node structure: PRV dx ien ^ hospital location ^ visit date&time
+27 SET TCNT=1
SET VCNT=0
FOR
SET VCNT=$ORDER(VISITS(VCNT))
if 'VCNT
QUIT
Begin DoDot:3
+28 SET PRVIEN=$ORDER(^DSIPPRV("B",VISITS(VCNT),""))
if 'PRVIEN
QUIT
+29 SET PRV0=$GET(^DSIPPRV(PRVIEN,0))
+30 SET LOC=$$GET1^DIQ(9000010,VISITS(VCNT),.22)
+31 SET DATE=$$GET1^DIQ(9000010,VISITS(VCNT),.01)
+32 FOR I=2:1:4
IF $PIECE(PRV0,U,I)'=""
SET PRVS(TCNT)=$PIECE(PRV0,U,I)_U_LOC_U_DATE
SET TCNT=TCNT+1
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 DO DISP
if +$GET(TCNT)>0
DO NEWDX(TCNT-1)
IF $DATA(IBLIST)
DO ADDNEW
+37 DO DISPEX(IBIFN)
+38 DO CLEAN^DILF
EN1 ;
+1 SET IBDX=$$ASKDX
IF +IBDX>0
DO ADD($PIECE(IBDX,U))
DO EDIT(+IBDX)
GOTO EN1
+2 QUIT
+3 ;
DISP ; display PRV diagnoses
+1 NEW CNT,DXCODE,I,IBDX,PRV
+2 WRITE @IOF,!,"===================Pt. Reason for Visit Diagnosis Screen ====================",!
+3 IF '$DATA(PRVS)
WRITE !,?13,"No available Pt. Reason for Visit Diagnoses found."
QUIT
+4 SET CNT=0
FOR
SET CNT=$ORDER(PRVS(CNT))
if 'CNT
QUIT
Begin DoDot:1
+5 SET IBDX=$$ICD9^IBACSV($PIECE(PRVS(CNT),U),$$BDATE^IBACSV(IBIFN))
SET DXCODE=$PIECE(IBDX,U)
+6 FOR I=8:1:10
SET PRV=$PIECE($GET(^DGCR(399,IBIFN,"U3")),U,I)
IF PRV=+PRVS(CNT)
SET DXCODE="*"_DXCODE
QUIT
+7 WRITE !,$JUSTIFY(CNT,2),")",?4,DXCODE,?15,$EXTRACT($PIECE(IBDX,U,3),1,30),?46,$EXTRACT($PIECE(PRVS(CNT),U,2),1,14),?62,$PIECE(PRVS(CNT),U,3)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
DISPEX(IBIFN) ; display existing PRV diagnoses for a bill
+1 NEW I,IBDX,IBDXDT
+2 WRITE !!,?5,"------ Existing Pt. Reason for Visit Diagnoses for Bill -------",!
+3 FOR I=8:1:10
SET IBDX=$PIECE($GET(^DGCR(399,IBIFN,"U3")),U,I)
IF IBDX'=""
Begin DoDot:1
+4 SET IBDXDT=$$ICD9^IBACSV(IBDX,$$BDATE^IBACSV(IBIFN))
+5 WRITE !,?5,$PIECE(IBDXDT,U),?17,$PIECE(IBDXDT,U,3)
End DoDot:1
+6 ;
+7 if $GET(IBDXDT)=""
WRITE !,?13,"No existing Pt. Reason for Visit Diagnoses found."
+8 WRITE !
+9 QUIT
+10 ;
CHKPRV() ; check how many PRVs are not populated (out of 3)
+1 NEW CNT,I
+2 SET CNT=3
FOR I=8:1:10
IF $PIECE($GET(^DGCR(399,IBIFN,"U3")),U,I)'=""
SET CNT=CNT-1
+3 QUIT CNT
+4 ;
PRVFLD(DXIEN) ; returns the field number that contains DXIEN
+1 ; if DXIEN="", returns the first empty PRV field number
+2 ; if no match found (or no empty fields), returns 0
+3 NEW I,FLD
+4 SET FLD=0
FOR I=8:1:10
IF $PIECE($GET(^DGCR(399,IBIFN,"U3")),U,I)=DXIEN
SET FLD=I+241
QUIT
+5 QUIT FLD
+6 ;
ERR ; display error message
+1 WRITE !,?6,"You may add a maximum of 3 PRV diagnoses to a claim."
+2 QUIT
+3 ;
NEWDX(IBX) ; select PRV diagnosis to add to bill
+1 ; IBX - max. number of PRV diagnoses available
+2 NEW X,Y,DIR,DIRUT
+3 ;
if 'IBX!('$$CHKPRV)
QUIT
+4 WRITE !
NEWDX1 SET DIR("?",1)="Enter the number preceding the PRV diagnosis you want added to the bill."
SET DIR("?")="Multiple entries may be added separated by commas or ranges separated by a dash."
+1 SET DIR("A")="Select Pt. Reason for Visit Diagnosis to add to bill"
+2 SET DIR(0)="LO^1:"_+IBX
DO ^DIR
KILL DIR
if 'Y!$DATA(DIRUT)
GOTO NEWDXE
+3 SET IBLIST=Y
+4 SET DIR("A")="You have selected "_IBLIST_" to be added to the bill. Is this correct"
SET DIR("B")="YES"
+5 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL IBLIST
GOTO NEWDXE
+6 IF 'Y
GOTO NEWDX1
+7 IF $LENGTH(IBLIST,",")-1>$$CHKPRV
DO ERR
GOTO NEWDX1
NEWDXE QUIT
+1 ;
ADD(DXIEN) ; add single PRV diagnosis with file 80 ien DXIEN to the bill
+1 ; quit if no dx ien or if such PRV already exists
if 'DXIEN!$$PRVFLD(DXIEN)
QUIT
+2 NEW FLD
+3 ; if there are already 3 PRVs on the claim, complain and bail out
+4 IF '$$CHKPRV
DO ERR
QUIT
+5 SET FLD=$$PRVFLD("")
IF FLD
SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR=FLD_"////"_DXIEN
DO ^DIE
KILL DA,DIE
+6 QUIT
+7 ;
ADDNEW ; add selected PRV diagnoses to the bill
+1 if '$DATA(PRVS)
QUIT
+2 NEW I,IBX
+3 FOR I=1:1
SET IBX=$PIECE(IBLIST,",",I)
if 'IBX
QUIT
IF $DATA(PRVS(IBX))
DO ADD(+PRVS(IBX))
+4 QUIT
+5 ;
ASKDX() ; enter extra PRV diagnosis
+1 ; returns dx ien in file 80 ^ dx code
+2 NEW X,Y,IBDATE,IBDTTX,ICDVDT
+3 SET IBDATE=$$BDATE^IBACSV(IBIFN)
SET ICDVDT=IBDATE
+4 SET IBDTTX=$$DAT1^IBOUTL(IBDATE)
AD ;
+1 SET DIR("?")="Enter a diagnosis for this bill. Only diagnosis codes active on "_IBDTTX_" are allowed."
+2 ; inactive allowed but either ICD-9 or ICD-10 *461
SET DIR("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE)
+3 SET DIR(0)="PO^80:EAMQI"
SET DIR("A")="Enter Pt. Reason for Visit Diagnosis"
+4 DO ^DIR
KILL DIR
+5 IF Y>0
IF '$$PRVFLD(+Y)
IF '$$ICD9ACT^IBACSV(+Y,IBDATE)
Begin DoDot:1
+6 WRITE !!,*7,"The Diagnosis code is inactive for the date of service ("_IBDTTX_").",!
End DoDot:1
GOTO AD
+7 QUIT Y
+8 ;
EDIT(DXIEN) ; edit/delete PRV diagnosis
+1 NEW IBU3,FLD,PRV2,PRV3
+2 if 'DXIEN
QUIT
SET FLD=$$PRVFLD(DXIEN)
IF FLD
SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR=FLD
DO ^DIE
KILL DIE,DR,DA
+3 ; if PRV was deleted, rearrange PRVs to maintain their order of entry
+4 SET IBU3=$GET(^DGCR(399,IBIFN,"U3"))
IF $PIECE(IBU3,U,FLD-241)=""
Begin DoDot:1
+5 ; PRV(1) was deleted, PRV(2) is not empty
+6 IF FLD=249
SET PRV2=$PIECE(IBU3,U,9)
if PRV2'=""
SET PRV3=$PIECE(IBU3,U,10)
SET DR="249////"_PRV2_";"_$SELECT(PRV3'="":"250////"_PRV3_";251///@",1:"250///@")
+7 ; PRV(2) was deleted, PRV(3) is not empty
+8 IF FLD=250
SET PRV3=$PIECE(IBU3,U,10)
IF PRV3'=""
SET DR="250////"_PRV3_";251///@"
+9 ; if PRV(3) is deleted, no rearrangements are necessary
+10 QUIT
End DoDot:1
+11 IF $GET(DR)'=""
SET DIE="^DGCR(399,"
SET DA=IBIFN
DO ^DIE
KILL DIE,DR,DA
+12 QUIT
+13 ;
DELALL(IBIFN) ; ask/delete all PRV diagnoses on the bill
+1 NEW DIE,DA,DR,DIR,DIRUT,DUOUT,DTOUT,X,Y
WRITE !
+2 SET DIR("?")="Enter Yes to delete all PRV diagnoses currently defined for a bill."
SET DIR("??")="^D DISPEX^IBCSC10B("_IBIFN_")"
+3 SET DIR("A")="Delete all Patient Reason for Visit diagnoses on bill"
+4 SET DIR(0)="YO"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if Y'=1
QUIT
+5 ;
+6 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR="249///@;250///@;251///@"
DO ^DIE
+7 WRITE " .... deleted"
+8 QUIT
