IBACCWLRURREV ;EDE/TPF - ACC (Automated Community Care) Claims - ADDITIONAL REVIEW SCREEN FOR RUR ; 12-SEP-2023 ; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
Q
;ROUTINE CLONED FROM IBACCWLVE BUT MAY HAVE A LOTS OF CHANGES BECAUSE THIS IS A BIG REDESIGN
;WE MAY NEED TO DUMP THIS CODE PARADIGN COMPLETELY
;NEW ROUTINE IN TPF;IB*2*770vPURPLE;EBILL-5721
;
;NOT SURE WE NEED ALL THESE PASSED
EN(IBDA,IBENCIFN,IBIFN,DETRETURN,PREVVALMAR,IBFROMVALMDDF) ;TPF;IB*2*770v38;EBILL-5485
N D,D1,SBR,VALMAR,VALMCNT,VALMHDR,VALMSG
;
N IBPARENT S IBPARENT=0
S IBACCWLRURREVLEV=$G(IBACCWLRURREVLEV)+1
D EN^VALM("IBACC WL IBACCRUR REVIEW")
;
Q
;
HDR ; -- header code
;
N PTDOB,PTSSN,PTNAME
S ENCOUNTER=$$GET1^DIQ(364.9,$G(IBENCIFN)_",",.15,"E")
S IBBILL=$$GET1^DIQ(364.9,$G(IBENCIFN)_",",2.02,"E")
S IBIFN=$$GET1^DIQ(364.9,$G(IBENCIFN)_",",2.02,"I")
S PTNAME=$$PTNAME^IBACCWLUTIL1(IBENCIFN)
S:$P($G(^IBA(364.9,IBENCIFN,2)),U) PTNAME=$$GET1^DIQ(364.9,$G(IBENCIFN)_",",2.01,"E")
S PTSSN=$$GET1^DIQ(364.9,$G(IBENCIFN)_",",.11,"E")
S:PTSSN'="" PTSSN=$E(PTSSN,1,3)_"-"_$E(PTSSN,4,5)_"-"_$E(PTSSN,6,9) ;TPF;IB*2*770V44;EBILL-5975 ;MJL;IB*2*770v55;EBILL-6296
S PTDOB=$$GET1^DIQ(364.9,$G(IBENCIFN)_",",.1,"I") ;TPF;IB*2*770V44;EBILL-5975
S PTDOB=$$FMTE^XLFDT(PTDOB,5)
;
S VALMHDR(1)="Patient: "_$G(PTNAME)_" "_$G(PTSSN)_" DOB:"_PTDOB
;
S VALMSG="Encounter: "_$G(ENCOUNTER)_"|"_$G(IBBILL)
;
Q
;
INIT ;EP -- init variables and list array
N CLM,CLMCNT,CODE,D,D1,HI,HL,IOD,LINEBLK,LINEVAR,NODE,SBR,TAX
N IBDRG,IBDX,IBPROC,IBFORM,IBINOUT,DTOFOCCFR,DTOFOCCTO,SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND,GETX12TPE
N TTMPVALMDDF,DFN ;TPF XINDEX
N DIAGPTRARR ;TPF;IB*27*70v38;EBILL-5483 Diagnosis Code Pointer ARRAY
;
S (SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND)=0
;
S D="*",D1=":"
D PRESCAN(IBENCIFN,.IBDRG,.DTOFOCCFR,.DTOFOCCTO,0,SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND) ;EP - GRAB SEGMENTS NEEDED FOR SECTION HEADER
;
S VALMCNT=0
S DFN=$$GET1^DIQ(364.9,IBENCIFN_",",2.01,"I")
;
;D SET("","",1,"") ;REMOVED LINE FEED TO PLACE IEN ON THE TOP LINE ;MJL;EBILL-6200
I $G(DUZ(0))="@" D SET("IEN",IBENCIFN)
;
S IBDX=$$GET1^DIQ(364.9,IBENCIFN_",",.14,"E")_$$GET1^DIQ(364.9,IBENCIFN_",",.3,"E") ;IF NULL THEN NO DIAGNOSIS
S IBPROC=$$GET1^DIQ(364.9,IBENCIFN_",",.13,"E") ;IF NULL THEN NO PROCEDURES
S IBFORM=$$GET1^DIQ(364.9,IBENCIFN_",",.06,"E")
S IBINOUT=$TR($$GET1^DIQ(364.9,IBENCIFN_",",.05,"E"),"-") ;MEANS NOTHING FOR EXTRACTING CODE FOR DISPLAY
I $G(SV1CODEFOUND)'=""!($G(SV2CODEFOUND)'="")!($G(SV3CODEFOUND)'="") S IBPROC=1 ;PRESCAN OVERRIDES #.13 CPT FIELD FOR NOW
;
; with qualifier = 435 Admission Date - it's a required segment for inpatient services.
;by default, all encounters are set as outpatient, until and if this DTP segment is found
;then it's labeled as an inpatient encounter. CAN NOT RELY ON FOR DETERMINING DISPLAY API
;
D SET("Patient Type:",$G(IBINOUT)_" "_$S(IBINOUT="INPATIENT":"DRG:"_$G(IBDRG),1:"")_" "_"From:"_$G(DTOFOCCFR)_" To:"_$G(DTOFOCCTO))
;
D SET("")
;
N ABFCNT,ENCOUNTER,HICNT,IBBILL,IBIFN,SV1LEVEL,SV2LEVEL,SV3LEVEL,BBQLEVEL,DIAGCNT ;TPF XINDEX
S (SV1LEVEL,SV2LEVEL,SV3LEVEL,BBQLEVEL)=0 ;USED TO DETERMINE PRINTING LABELS
S (CLM,CLMCNT,HI,HL,SBR)=0
S IOD=$$GET1^DIQ(364.9,IBENCIFN,.05,"I")
S (ABFCNT,DIAGCNT)=0 ;NUMBER OF ABF QC FOUND IN GIVEN CLAIM. USED TO DETERMINE PRINTING LABELS
F S CLMCNT=$O(^IBA(364.9,IBENCIFN,1,CLMCNT)) Q:'CLMCNT S DATA=^(CLMCNT,0) Q:DATA="" D
. S NODE=$P(DATA,D,1)
. I ",ST,HI,SV1,SV2,SV3,"'[(","_NODE_",") Q
. I ",ST,"[(","_NODE_",") D GETX12TPE(DATA,.GETX12TPE) Q
. I ",HI,"[(","_NODE_",") S NODE=NODE_"^IBACCWLRURREV1A(.ABFCNT,.DIAGCNT,GETX12TPE)" ;TPF;IB*2*770v770PURPLE;EBILL-9999 SAC SIZE
. ;I ",DTP,"[(","_NODE_",") S NODE=NODE_"^IBACCWLRURREV1" ;DOES NOT WORK BECAUSE THEY WANT DATE DISPLAYED BEFORE THE LINE ITEMS
. I ",SV1,"[(","_NODE_",") S NODE=NODE_"^IBACCWLRURREV3"
. I ",SV2,"[(","_NODE_",") S NODE=NODE_"^IBACCWLRURREV3"
. I ",SV3,"[(","_NODE_",") S NODE=NODE_"^IBACCWLRURREV3"
. ;
. D @NODE
;
D SET("<end of codes>","","","","1^15","16^16") ;MUST HAVE TITLE AND VALUE DDF OVERRIDES TO WORK CORRECTLY? CHNAGE IN FUTURE
;
;MOVE THE VS SECTION BELOW THE ENCOUNTER - ;MJL;EBILL-6200
D SET("") ;ADDED EXTRA LINE FEED TO LOOK PRETTIER
I $G(DFN) M TTMPVALMDDF=VALMDDF D GETVALMDDF("IBACC WL VS",.VALMDDF) Q:'$D(VALMDDF) D BLD^IBACCWLVS K VALMDDF M VALMDDF=TTMPVALMDDF
E D SET("PATIENT PROFILE CAN NOT BE INSERTED BECAUSE NO PATIENT FOUND.")
;END MJL;EBILL-6200
;
;BEGIN TPF*IB*2*770v68;EBILL-5485,5721
I $G(IBENCIFN) D
.S @VALMAR@("IEN3649",1)=IBENCIFN
.S IBIFN=$$GET1^DIQ(364.9,IBENCIFN_",",2.02,"I")
S:$G(IBIFN) @VALMAR@("IEN399",1)=IBIFN
;END TPF*IB*2*770v38;EBILL-5485,5721
;
GETX12TPE(DATA,GETX12TPE) ;EP GET X12 TYPE
;
N X12 ;TPF XINDEX
;ST*837*0001*005010X222A1
;For 837 Institutional (837I), the ST01 value is 005010X223A2.
;For 837 Professional (837P), the ST01 value is 005010X222A1.
;For 837 Dental (837D), the ST01 value is 005010X224A2
S X12=$P(DATA,D,4)
S X12=$E(X12,8,10)
I X12="223" S GETX12TPE="UBHI"
E S GETX12TPE=""
;
Q
;
INITQ ;Exit
I '$D(@VALMAR) D SET^VALM10(1,"NO DATA FOUND!!")
Q
;
PRESCANALL ;EP
N IBENCIFN,PRESCAN,DRG,DTOFOCC
S IBENCIFN=0
F S IBENCIFN=$O(^IBA(364.9,IBENCIFN)) Q:'IBENCIFN D
.D PRESCAN(IBENCIFN,.DRG,.DTOFOCC)
.W !,IBENCIFN,?15,DRG,?25,DTOFOCC
Q
;
PRESCAN(IBENCIFN,DRG,DTOFOCCFR,DTOFOCCTO,DISPLAY,SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND) ;EP - GRAB SEGMENTS NEEDED FOR SECTION HEADER
;
;DRG WILL NEVER BE FOUND IN ACC ENCOUNTERS. IN THIS APP IT IS A PLACEHOLDER FOR WHEN IT IS CACLULATED IN PTF
;RETURN DRG AND DATES OF OCURRENCE
S DISPLAY=$G(DISPLAY)
;
N SEGIEN,DTPDTRANGE,DTPFOUND,INOUTPT,SV1DX,SV2DX,SV3DX,SV1CODE,SV2CODE,SV3CODE ;TPF XINDEX
N SV1DXFOUND,SV2DXFOUND,SV3DXFOUND
N ASSGRP,DATA,STATUS
;
S (DRG,DTOFOCC,DTPDTRANGE,DTPFOUND)=""
S SEGIEN=0
F S SEGIEN=$O(^IBA(364.9,IBENCIFN,1,SEGIEN)) Q:'SEGIEN D
.S DATA=$G(^IBA(364.9,IBENCIFN,1,SEGIEN,0))
.;
.I $P(DATA,"*")="SV2" D
..S SV2CODE=$P($P(DATA,D,3),D1,1)
..I SV2CODE'="" S SV2CODEFOUND=1 ;FLAG FOR CODEFOUND IF NO CODE FOUND DISPLAY "No Procedure Codes Found"
.;
.I $P(DATA,"*")="SV1" D
..S SV1DX=$P($P(DATA,D,3),D1,1)
..I SV1DX'="" S SV1DXFOUND=1 ;FLAG FOR CODEFOUND IF NO CODE FOUND DISPLAY "No Dx Found"
.;
.I $P(DATA,"*")="SV3" D
..S SV3DX=$P($P(DATA,D,3),D1,1)
..I SV3DX'="" S SV3DXFOUND=1 ;FLAG FOR CODEFOUND IF NO CODE FOUND DISPLAY "No Dx Found"
.;
.I $E(DATA,1,3)="DTP",'DTPFOUND D
..Q:(U_434_U_472_U)'[(U_$P(DATA,"*",2)_U) ;434 = DATE RANGE, 472 = DATE OF SERVICE
..I $P(DATA,"*",2)=434 D
...S DTPFOUND=1
...S DTOFOCC=$P($P(DATA,"*",4),"~") ;DTP*434*RD8*20230501-20230510~ # Statement Dates
...S DTOFOCCFR=$P(DTOFOCC,"-")
...S DTOFOCCTO=$P(DTOFOCC,"-",2)
..E I $P(DATA,"*",4)'="" S DTPDTRANGE($P(DATA,"*",4),SEGIEN)="",DTPDTRANGE=DTPDTRANGE+1
.;
.I $E(DATA,1,2)="HI" D
..I DATA[("*DR:") S DRG=$P(DATA,"*DR:",2) ;TIMZ LOOKED FOR DRG IN HI*DR
..I DATA[("*DRG:") S DRG=$P(DATA,"*DRG:",2) ;VAGPT SAID DRG
..I DATA[("*BI:") S DTOFOCC=$P($P(DATA,"*BI:",2),":",3) ;HI*BI:73:RD8:20230522-20230531 RD8 = RANGE OF DATES
..I DTOFOCC'="" D
...S DTOFOCCFR=$P(DTOFOCC,"-")
...S DTOFOCCTO=$P(DTOFOCC,"-",2)
...;
...S DTOFOCCFR=$E(DTOFOCCFR,5,6)_"/"_$E(DTOFOCCFR,7,8)_"/"_$E(DTOFOCCFR,1,4)
...S DTOFOCCTO=$E(DTOFOCCTO,5,6)_"/"_$E(DTOFOCCTO,7,8)_"/"_$E(DTOFOCCTO,1,4)
...;
..;DEBUGGING CODE
..I $G(DRG)'=""!($G(DTOFOCC)'="") D
...S STATUS=$$GET1^DIQ(364.9,IBENCIFN_",",.16,"E")
...Q:STATUS="CLOSED"!(STATUS="PURGED")
...I $G(DRG)'="",($G(DTOFOCC)'="") I $G(DISPLAY) W !,"****************",IBENCIFN,"****",SEGIEN ;B:$G(DUZ)=786223 "S"
...Q:'$G(DISPLAY)
...S ASSGRP=$$GET1^DIQ(364.9,IBENCIFN_",",3.01,"E")
...S INOUTPT=$$GET1^DIQ(364.9,IBENCIFN_",",.05,"E")
...W !,IBENCIFN
...W !?5,"IN/OUT:",INOUTPT
...W !?5,"ASSGNGRP:",ASSGRP
...W !?5," DRG: ",$G(DRG)
...W !?5,"DTOFOCC: ",$G(DTOFOCC)
...K DRG,DTOFOCC
;
Q:$G(DTOFOCCFR)'=""&($G(DTOFOCCTO)'="")
;
I $D(DTPDTRANGE)#10 D
.I DTPDTRANGE=1 D
..S DTOFOCCFR=$O(DTPDTRANGE("")),DTOFOCCTO=DTOFOCCFR
.E S DTOFOCCFR=$O(DTPDTRANGE("")),DTOFOCCTO=$O(DTPDTRANGE(""),-1)
.;
.S DTOFOCCFR=$E(DTOFOCCFR,5,6)_"/"_$E(DTOFOCCFR,7,8)_"/"_$E(DTOFOCCFR,1,4)
.S:DTOFOCCTO'="" DTOFOCCTO=$E(DTOFOCCTO,5,6)_"/"_$E(DTOFOCCTO,7,8)_"/"_$E(DTOFOCCTO,1,4)
;
Q
;
HELP ; -- help code
;
N X
S X="?" D DISP^XQORM1 W !!
;
Q
;
EXIT ; -- exit code
;
S IBACCWLRURREVLEV=$G(IBACCWLRURREVLEV)-1 ;TPF;IB*2*770v44;EBILL-6011
I $G(IBACCWLVELEV)>1 Q
D CLEAN^VALM10 ;KILLS DATA AND VIDEO CONTROL ARRAYS. KILLS @VALMAR TOO
;
Q
;
EXPND ; -- expand code
Q
;
SET(TITLE,VALUE,BLANK,HEADER,TITLECOLDDF,VALUECOLDDF,THIRDCOLDDF) ;EP -MODIFIED SET TO PLACE DATA AT SPECIFIC COLUMN
N T1,WIDTH,COL
S TITLECOLDDF=$G(TITLECOLDDF)
S VALUECOLDDF=$G(VALUECOLDDF)
S THIRDCOLDDF=$G(THIRDCOLDDF)
;
S TITLE=$G(TITLE),VALUE=$G(VALUE)
I $G(BLANK) S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT," ")
I $G(HEADER) D G SETQ
. I '$L(TITLE) Q
. S VALMCNT=VALMCNT+1
. S COL=((IOM/2)-($L(TITLE)/2))\1
. S WIDTH=$L(TITLE)
. D CNTRL^VALM10(VALMCNT,COL,WIDTH,IORVON,IORVOFF)
. S TITLE=$$SETSTR^VALM1(TITLE,"",COL,WIDTH)
. D SET^VALM10(VALMCNT,TITLE)
S LINEVAR=""
D SET1(TITLE,VALUE,TITLECOLDDF,VALUECOLDDF,THIRDCOLDDF)
SETQ ;
Q
;
SET1(TITLE,VALUE,TITLECOLDDF,VALUECOLDDF,THIRDCOLDDF) ;EP
;
N VALUE3RDCOL
;
I TITLE[("Patient Type") S TITLE=TITLE_" "_$G(VALUE) S VALUE="" ;LEAVE FIOR NOW. THIS NEEDS FOUR COLIUMNS
I TITLE[("IEN") S TITLE=TITLE_" "_$G(VALUE)
;
I $G(TITLECOLDDF),$G(VALUECOLDDF) D
.N TITLESTART,TITLEWIDTH,VALSTART,VALWIDTH
.S TITLESTART=$P(TITLECOLDDF,U)
.S TITLEWIDTH=$P(TITLECOLDDF,U,2)
.S VALSTART=$P(VALUECOLDDF,U)
.S VALWIDTH=$P(VALUECOLDDF,U,2)
.S VALMDDF("NODE")="NODE^"_TITLESTART_U_TITLEWIDTH
.S VALMDDF("DATA")="DATA^"_VALSTART_U_VALWIDTH
.I $G(THIRDCOLDDF)'="" D
..S VALMDDF("3RDCOL")="3RDCOL^"_$P(THIRDCOLDDF,U)_U_$P(THIRDCOLDDF,U,2)
..S VALUE3RDCOL=$P(THIRDCOLDDF,U,3)
;
S LINEVAR=$$SETFLD^VALM1(TITLE,LINEVAR,"NODE")
S LINEVAR=$$SETFLD^VALM1(VALUE,LINEVAR,"DATA")
I $D(VALMDDF("3RDCOL")) S LINEVAR=$$SETFLD^VALM1(VALUE3RDCOL,LINEVAR,"3RDCOL") K VALMDDF("3RDCOL")
S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,LINEVAR)
Q
;
GETVALMDDF(LISTNAME,VALMDDF) ;EP GET VALMDDF FIELD DEF ARRAY
;
Q:$G(LISTNAME)=""
N I,LISTIEN
S LISTIEN=$O(^SD(409.61,"B",LISTNAME,""))
;I LISTIEN="" W !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!" S ABORT=1 Q
I LISTIEN="" W !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!" Q ;XINDEX MJL
S I=0 ;SET UP COLUMN DATA ARRAY
F S I=$O(^SD(409.61,LISTIEN,"COL",I)) Q:'I I $D(^(I,0)) S VALMDDF($P(^(0),U))=^(0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLRURREV 11087 printed May 25, 2026@12:10:04 Page 2
IBACCWLRURREV ;EDE/TPF - ACC (Automated Community Care) Claims - ADDITIONAL REVIEW SCREEN FOR RUR ; 12-SEP-2023 ; 12-SEP-2023
+1 ;;2.0;INTEGRATED BILLING;**770**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;ROUTINE CLONED FROM IBACCWLVE BUT MAY HAVE A LOTS OF CHANGES BECAUSE THIS IS A BIG REDESIGN
+5 ;WE MAY NEED TO DUMP THIS CODE PARADIGN COMPLETELY
+6 ;NEW ROUTINE IN TPF;IB*2*770vPURPLE;EBILL-5721
+7 ;
+8 ;NOT SURE WE NEED ALL THESE PASSED
EN(IBDA,IBENCIFN,IBIFN,DETRETURN,PREVVALMAR,IBFROMVALMDDF) ;TPF;IB*2*770v38;EBILL-5485
+1 NEW D,D1,SBR,VALMAR,VALMCNT,VALMHDR,VALMSG
+2 ;
+3 NEW IBPARENT
SET IBPARENT=0
+4 SET IBACCWLRURREVLEV=$GET(IBACCWLRURREVLEV)+1
+5 DO EN^VALM("IBACC WL IBACCRUR REVIEW")
+6 ;
+7 QUIT
+8 ;
HDR ; -- header code
+1 ;
+2 NEW PTDOB,PTSSN,PTNAME
+3 SET ENCOUNTER=$$GET1^DIQ(364.9,$GET(IBENCIFN)_",",.15,"E")
+4 SET IBBILL=$$GET1^DIQ(364.9,$GET(IBENCIFN)_",",2.02,"E")
+5 SET IBIFN=$$GET1^DIQ(364.9,$GET(IBENCIFN)_",",2.02,"I")
+6 SET PTNAME=$$PTNAME^IBACCWLUTIL1(IBENCIFN)
+7 if $PIECE($GET(^IBA(364.9,IBENCIFN,2)),U)
SET PTNAME=$$GET1^DIQ(364.9,$GET(IBENCIFN)_",",2.01,"E")
+8 SET PTSSN=$$GET1^DIQ(364.9,$GET(IBENCIFN)_",",.11,"E")
+9 ;TPF;IB*2*770V44;EBILL-5975 ;MJL;IB*2*770v55;EBILL-6296
if PTSSN'=""
SET PTSSN=$EXTRACT(PTSSN,1,3)_"-"_$EXTRACT(PTSSN,4,5)_"-"_$EXTRACT(PTSSN,6,9)
+10 ;TPF;IB*2*770V44;EBILL-5975
SET PTDOB=$$GET1^DIQ(364.9,$GET(IBENCIFN)_",",.1,"I")
+11 SET PTDOB=$$FMTE^XLFDT(PTDOB,5)
+12 ;
+13 SET VALMHDR(1)="Patient: "_$GET(PTNAME)_" "_$GET(PTSSN)_" DOB:"_PTDOB
+14 ;
+15 SET VALMSG="Encounter: "_$GET(ENCOUNTER)_"|"_$GET(IBBILL)
+16 ;
+17 QUIT
+18 ;
INIT ;EP -- init variables and list array
+1 NEW CLM,CLMCNT,CODE,D,D1,HI,HL,IOD,LINEBLK,LINEVAR,NODE,SBR,TAX
+2 NEW IBDRG,IBDX,IBPROC,IBFORM,IBINOUT,DTOFOCCFR,DTOFOCCTO,SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND,GETX12TPE
+3 ;TPF XINDEX
NEW TTMPVALMDDF,DFN
+4 ;TPF;IB*27*70v38;EBILL-5483 Diagnosis Code Pointer ARRAY
NEW DIAGPTRARR
+5 ;
+6 SET (SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND)=0
+7 ;
+8 SET D="*"
SET D1=":"
+9 ;EP - GRAB SEGMENTS NEEDED FOR SECTION HEADER
DO PRESCAN(IBENCIFN,.IBDRG,.DTOFOCCFR,.DTOFOCCTO,0,SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND)
+10 ;
+11 SET VALMCNT=0
+12 SET DFN=$$GET1^DIQ(364.9,IBENCIFN_",",2.01,"I")
+13 ;
+14 ;D SET("","",1,"") ;REMOVED LINE FEED TO PLACE IEN ON THE TOP LINE ;MJL;EBILL-6200
+15 IF $GET(DUZ(0))="@"
DO SET("IEN",IBENCIFN)
+16 ;
+17 ;IF NULL THEN NO DIAGNOSIS
SET IBDX=$$GET1^DIQ(364.9,IBENCIFN_",",.14,"E")_$$GET1^DIQ(364.9,IBENCIFN_",",.3,"E")
+18 ;IF NULL THEN NO PROCEDURES
SET IBPROC=$$GET1^DIQ(364.9,IBENCIFN_",",.13,"E")
+19 SET IBFORM=$$GET1^DIQ(364.9,IBENCIFN_",",.06,"E")
+20 ;MEANS NOTHING FOR EXTRACTING CODE FOR DISPLAY
SET IBINOUT=$TRANSLATE($$GET1^DIQ(364.9,IBENCIFN_",",.05,"E"),"-")
+21 ;PRESCAN OVERRIDES #.13 CPT FIELD FOR NOW
IF $GET(SV1CODEFOUND)'=""!($GET(SV2CODEFOUND)'="")!($GET(SV3CODEFOUND)'="")
SET IBPROC=1
+22 ;
+23 ; with qualifier = 435 Admission Date - it's a required segment for inpatient services.
+24 ;by default, all encounters are set as outpatient, until and if this DTP segment is found
+25 ;then it's labeled as an inpatient encounter. CAN NOT RELY ON FOR DETERMINING DISPLAY API
+26 ;
+27 DO SET("Patient Type:",$GET(IBINOUT)_" "_$SELECT(IBINOUT="INPATIENT":"DRG:"_$GET(IBDRG),1:"")_" "_"From:"_$GET(DTOFOCCFR)_" To:"_$GET(DTOFOCCTO))
+28 ;
+29 DO SET("")
+30 ;
+31 ;TPF XINDEX
NEW ABFCNT,ENCOUNTER,HICNT,IBBILL,IBIFN,SV1LEVEL,SV2LEVEL,SV3LEVEL,BBQLEVEL,DIAGCNT
+32 ;USED TO DETERMINE PRINTING LABELS
SET (SV1LEVEL,SV2LEVEL,SV3LEVEL,BBQLEVEL)=0
+33 SET (CLM,CLMCNT,HI,HL,SBR)=0
+34 SET IOD=$$GET1^DIQ(364.9,IBENCIFN,.05,"I")
+35 ;NUMBER OF ABF QC FOUND IN GIVEN CLAIM. USED TO DETERMINE PRINTING LABELS
SET (ABFCNT,DIAGCNT)=0
+36 FOR
SET CLMCNT=$ORDER(^IBA(364.9,IBENCIFN,1,CLMCNT))
if 'CLMCNT
QUIT
SET DATA=^(CLMCNT,0)
if DATA=""
QUIT
Begin DoDot:1
+37 SET NODE=$PIECE(DATA,D,1)
+38 IF ",ST,HI,SV1,SV2,SV3,"'[(","_NODE_",")
QUIT
+39 IF ",ST,"[(","_NODE_",")
DO GETX12TPE(DATA,.GETX12TPE)
QUIT
+40 ;TPF;IB*2*770v770PURPLE;EBILL-9999 SAC SIZE
IF ",HI,"[(","_NODE_",")
SET NODE=NODE_"^IBACCWLRURREV1A(.ABFCNT,.DIAGCNT,GETX12TPE)"
+41 ;I ",DTP,"[(","_NODE_",") S NODE=NODE_"^IBACCWLRURREV1" ;DOES NOT WORK BECAUSE THEY WANT DATE DISPLAYED BEFORE THE LINE ITEMS
+42 IF ",SV1,"[(","_NODE_",")
SET NODE=NODE_"^IBACCWLRURREV3"
+43 IF ",SV2,"[(","_NODE_",")
SET NODE=NODE_"^IBACCWLRURREV3"
+44 IF ",SV3,"[(","_NODE_",")
SET NODE=NODE_"^IBACCWLRURREV3"
+45 ;
+46 DO @NODE
End DoDot:1
+47 ;
+48 ;MUST HAVE TITLE AND VALUE DDF OVERRIDES TO WORK CORRECTLY? CHNAGE IN FUTURE
DO SET("<end of codes>","","","","1^15","16^16")
+49 ;
+50 ;MOVE THE VS SECTION BELOW THE ENCOUNTER - ;MJL;EBILL-6200
+51 ;ADDED EXTRA LINE FEED TO LOOK PRETTIER
DO SET("")
+52 IF $GET(DFN)
MERGE TTMPVALMDDF=VALMDDF
DO GETVALMDDF("IBACC WL VS",.VALMDDF)
if '$DATA(VALMDDF)
QUIT
DO BLD^IBACCWLVS
KILL VALMDDF
MERGE VALMDDF=TTMPVALMDDF
+53 IF '$TEST
DO SET("PATIENT PROFILE CAN NOT BE INSERTED BECAUSE NO PATIENT FOUND.")
+54 ;END MJL;EBILL-6200
+55 ;
+56 ;BEGIN TPF*IB*2*770v68;EBILL-5485,5721
+57 IF $GET(IBENCIFN)
Begin DoDot:1
+58 SET @VALMAR@("IEN3649",1)=IBENCIFN
+59 SET IBIFN=$$GET1^DIQ(364.9,IBENCIFN_",",2.02,"I")
End DoDot:1
+60 if $GET(IBIFN)
SET @VALMAR@("IEN399",1)=IBIFN
+61 ;END TPF*IB*2*770v38;EBILL-5485,5721
+62 ;
GETX12TPE(DATA,GETX12TPE) ;EP GET X12 TYPE
+1 ;
+2 ;TPF XINDEX
NEW X12
+3 ;ST*837*0001*005010X222A1
+4 ;For 837 Institutional (837I), the ST01 value is 005010X223A2.
+5 ;For 837 Professional (837P), the ST01 value is 005010X222A1.
+6 ;For 837 Dental (837D), the ST01 value is 005010X224A2
+7 SET X12=$PIECE(DATA,D,4)
+8 SET X12=$EXTRACT(X12,8,10)
+9 IF X12="223"
SET GETX12TPE="UBHI"
+10 IF '$TEST
SET GETX12TPE=""
+11 ;
+12 QUIT
+13 ;
INITQ ;Exit
+1 IF '$DATA(@VALMAR)
DO SET^VALM10(1,"NO DATA FOUND!!")
+2 QUIT
+3 ;
PRESCANALL ;EP
+1 NEW IBENCIFN,PRESCAN,DRG,DTOFOCC
+2 SET IBENCIFN=0
+3 FOR
SET IBENCIFN=$ORDER(^IBA(364.9,IBENCIFN))
if 'IBENCIFN
QUIT
Begin DoDot:1
+4 DO PRESCAN(IBENCIFN,.DRG,.DTOFOCC)
+5 WRITE !,IBENCIFN,?15,DRG,?25,DTOFOCC
End DoDot:1
+6 QUIT
+7 ;
PRESCAN(IBENCIFN,DRG,DTOFOCCFR,DTOFOCCTO,DISPLAY,SV1CODEFOUND,SV2CODEFOUND,SV3CODEFOUND) ;EP - GRAB SEGMENTS NEEDED FOR SECTION HEADER
+1 ;
+2 ;DRG WILL NEVER BE FOUND IN ACC ENCOUNTERS. IN THIS APP IT IS A PLACEHOLDER FOR WHEN IT IS CACLULATED IN PTF
+3 ;RETURN DRG AND DATES OF OCURRENCE
+4 SET DISPLAY=$GET(DISPLAY)
+5 ;
+6 ;TPF XINDEX
NEW SEGIEN,DTPDTRANGE,DTPFOUND,INOUTPT,SV1DX,SV2DX,SV3DX,SV1CODE,SV2CODE,SV3CODE
+7 NEW SV1DXFOUND,SV2DXFOUND,SV3DXFOUND
+8 NEW ASSGRP,DATA,STATUS
+9 ;
+10 SET (DRG,DTOFOCC,DTPDTRANGE,DTPFOUND)=""
+11 SET SEGIEN=0
+12 FOR
SET SEGIEN=$ORDER(^IBA(364.9,IBENCIFN,1,SEGIEN))
if 'SEGIEN
QUIT
Begin DoDot:1
+13 SET DATA=$GET(^IBA(364.9,IBENCIFN,1,SEGIEN,0))
+14 ;
+15 IF $PIECE(DATA,"*")="SV2"
Begin DoDot:2
+16 SET SV2CODE=$PIECE($PIECE(DATA,D,3),D1,1)
+17 ;FLAG FOR CODEFOUND IF NO CODE FOUND DISPLAY "No Procedure Codes Found"
IF SV2CODE'=""
SET SV2CODEFOUND=1
End DoDot:2
+18 ;
+19 IF $PIECE(DATA,"*")="SV1"
Begin DoDot:2
+20 SET SV1DX=$PIECE($PIECE(DATA,D,3),D1,1)
+21 ;FLAG FOR CODEFOUND IF NO CODE FOUND DISPLAY "No Dx Found"
IF SV1DX'=""
SET SV1DXFOUND=1
End DoDot:2
+22 ;
+23 IF $PIECE(DATA,"*")="SV3"
Begin DoDot:2
+24 SET SV3DX=$PIECE($PIECE(DATA,D,3),D1,1)
+25 ;FLAG FOR CODEFOUND IF NO CODE FOUND DISPLAY "No Dx Found"
IF SV3DX'=""
SET SV3DXFOUND=1
End DoDot:2
+26 ;
+27 IF $EXTRACT(DATA,1,3)="DTP"
IF 'DTPFOUND
Begin DoDot:2
+28 ;434 = DATE RANGE, 472 = DATE OF SERVICE
if (U_434_U_472_U)'[(U_$PIECE(DATA,"*",2)_U)
QUIT
+29 IF $PIECE(DATA,"*",2)=434
Begin DoDot:3
+30 SET DTPFOUND=1
+31 ;DTP*434*RD8*20230501-20230510~ # Statement Dates
SET DTOFOCC=$PIECE($PIECE(DATA,"*",4),"~")
+32 SET DTOFOCCFR=$PIECE(DTOFOCC,"-")
+33 SET DTOFOCCTO=$PIECE(DTOFOCC,"-",2)
End DoDot:3
+34 IF '$TEST
IF $PIECE(DATA,"*",4)'=""
SET DTPDTRANGE($PIECE(DATA,"*",4),SEGIEN)=""
SET DTPDTRANGE=DTPDTRANGE+1
End DoDot:2
+35 ;
+36 IF $EXTRACT(DATA,1,2)="HI"
Begin DoDot:2
+37 ;TIMZ LOOKED FOR DRG IN HI*DR
IF DATA[("*DR:")
SET DRG=$PIECE(DATA,"*DR:",2)
+38 ;VAGPT SAID DRG
IF DATA[("*DRG:")
SET DRG=$PIECE(DATA,"*DRG:",2)
+39 ;HI*BI:73:RD8:20230522-20230531 RD8 = RANGE OF DATES
IF DATA[("*BI:")
SET DTOFOCC=$PIECE($PIECE(DATA,"*BI:",2),":",3)
+40 IF DTOFOCC'=""
Begin DoDot:3
+41 SET DTOFOCCFR=$PIECE(DTOFOCC,"-")
+42 SET DTOFOCCTO=$PIECE(DTOFOCC,"-",2)
+43 ;
+44 SET DTOFOCCFR=$EXTRACT(DTOFOCCFR,5,6)_"/"_$EXTRACT(DTOFOCCFR,7,8)_"/"_$EXTRACT(DTOFOCCFR,1,4)
+45 SET DTOFOCCTO=$EXTRACT(DTOFOCCTO,5,6)_"/"_$EXTRACT(DTOFOCCTO,7,8)_"/"_$EXTRACT(DTOFOCCTO,1,4)
+46 ;
End DoDot:3
+47 ;DEBUGGING CODE
+48 IF $GET(DRG)'=""!($GET(DTOFOCC)'="")
Begin DoDot:3
+49 SET STATUS=$$GET1^DIQ(364.9,IBENCIFN_",",.16,"E")
+50 if STATUS="CLOSED"!(STATUS="PURGED")
QUIT
+51 ;B:$G(DUZ)=786223 "S"
IF $GET(DRG)'=""
IF ($GET(DTOFOCC)'="")
IF $GET(DISPLAY)
WRITE !,"****************",IBENCIFN,"****",SEGIEN
+52 if '$GET(DISPLAY)
QUIT
+53 SET ASSGRP=$$GET1^DIQ(364.9,IBENCIFN_",",3.01,"E")
+54 SET INOUTPT=$$GET1^DIQ(364.9,IBENCIFN_",",.05,"E")
+55 WRITE !,IBENCIFN
+56 WRITE !?5,"IN/OUT:",INOUTPT
+57 WRITE !?5,"ASSGNGRP:",ASSGRP
+58 WRITE !?5," DRG: ",$GET(DRG)
+59 WRITE !?5,"DTOFOCC: ",$GET(DTOFOCC)
+60 KILL DRG,DTOFOCC
End DoDot:3
End DoDot:2
End DoDot:1
+61 ;
+62 if $GET(DTOFOCCFR)'=""&($GET(DTOFOCCTO)'="")
QUIT
+63 ;
+64 IF $DATA(DTPDTRANGE)#10
Begin DoDot:1
+65 IF DTPDTRANGE=1
Begin DoDot:2
+66 SET DTOFOCCFR=$ORDER(DTPDTRANGE(""))
SET DTOFOCCTO=DTOFOCCFR
End DoDot:2
+67 IF '$TEST
SET DTOFOCCFR=$ORDER(DTPDTRANGE(""))
SET DTOFOCCTO=$ORDER(DTPDTRANGE(""),-1)
+68 ;
+69 SET DTOFOCCFR=$EXTRACT(DTOFOCCFR,5,6)_"/"_$EXTRACT(DTOFOCCFR,7,8)_"/"_$EXTRACT(DTOFOCCFR,1,4)
+70 if DTOFOCCTO'=""
SET DTOFOCCTO=$EXTRACT(DTOFOCCTO,5,6)_"/"_$EXTRACT(DTOFOCCTO,7,8)_"/"_$EXTRACT(DTOFOCCTO,1,4)
End DoDot:1
+71 ;
+72 QUIT
+73 ;
HELP ; -- help code
+1 ;
+2 NEW X
+3 SET X="?"
DO DISP^XQORM1
WRITE !!
+4 ;
+5 QUIT
+6 ;
EXIT ; -- exit code
+1 ;
+2 ;TPF;IB*2*770v44;EBILL-6011
SET IBACCWLRURREVLEV=$GET(IBACCWLRURREVLEV)-1
+3 IF $GET(IBACCWLVELEV)>1
QUIT
+4 ;KILLS DATA AND VIDEO CONTROL ARRAYS. KILLS @VALMAR TOO
DO CLEAN^VALM10
+5 ;
+6 QUIT
+7 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
SET(TITLE,VALUE,BLANK,HEADER,TITLECOLDDF,VALUECOLDDF,THIRDCOLDDF) ;EP -MODIFIED SET TO PLACE DATA AT SPECIFIC COLUMN
+1 NEW T1,WIDTH,COL
+2 SET TITLECOLDDF=$GET(TITLECOLDDF)
+3 SET VALUECOLDDF=$GET(VALUECOLDDF)
+4 SET THIRDCOLDDF=$GET(THIRDCOLDDF)
+5 ;
+6 SET TITLE=$GET(TITLE)
SET VALUE=$GET(VALUE)
+7 IF $GET(BLANK)
SET VALMCNT=VALMCNT+1
DO SET^VALM10(VALMCNT," ")
+8 IF $GET(HEADER)
Begin DoDot:1
+9 IF '$LENGTH(TITLE)
QUIT
+10 SET VALMCNT=VALMCNT+1
+11 SET COL=((IOM/2)-($LENGTH(TITLE)/2))\1
+12 SET WIDTH=$LENGTH(TITLE)
+13 DO CNTRL^VALM10(VALMCNT,COL,WIDTH,IORVON,IORVOFF)
+14 SET TITLE=$$SETSTR^VALM1(TITLE,"",COL,WIDTH)
+15 DO SET^VALM10(VALMCNT,TITLE)
End DoDot:1
GOTO SETQ
+16 SET LINEVAR=""
+17 DO SET1(TITLE,VALUE,TITLECOLDDF,VALUECOLDDF,THIRDCOLDDF)
SETQ ;
+1 QUIT
+2 ;
SET1(TITLE,VALUE,TITLECOLDDF,VALUECOLDDF,THIRDCOLDDF) ;EP
+1 ;
+2 NEW VALUE3RDCOL
+3 ;
+4 ;LEAVE FIOR NOW. THIS NEEDS FOUR COLIUMNS
IF TITLE[("Patient Type")
SET TITLE=TITLE_" "_$GET(VALUE)
SET VALUE=""
+5 IF TITLE[("IEN")
SET TITLE=TITLE_" "_$GET(VALUE)
+6 ;
+7 IF $GET(TITLECOLDDF)
IF $GET(VALUECOLDDF)
Begin DoDot:1
+8 NEW TITLESTART,TITLEWIDTH,VALSTART,VALWIDTH
+9 SET TITLESTART=$PIECE(TITLECOLDDF,U)
+10 SET TITLEWIDTH=$PIECE(TITLECOLDDF,U,2)
+11 SET VALSTART=$PIECE(VALUECOLDDF,U)
+12 SET VALWIDTH=$PIECE(VALUECOLDDF,U,2)
+13 SET VALMDDF("NODE")="NODE^"_TITLESTART_U_TITLEWIDTH
+14 SET VALMDDF("DATA")="DATA^"_VALSTART_U_VALWIDTH
+15 IF $GET(THIRDCOLDDF)'=""
Begin DoDot:2
+16 SET VALMDDF("3RDCOL")="3RDCOL^"_$PIECE(THIRDCOLDDF,U)_U_$PIECE(THIRDCOLDDF,U,2)
+17 SET VALUE3RDCOL=$PIECE(THIRDCOLDDF,U,3)
End DoDot:2
End DoDot:1
+18 ;
+19 SET LINEVAR=$$SETFLD^VALM1(TITLE,LINEVAR,"NODE")
+20 SET LINEVAR=$$SETFLD^VALM1(VALUE,LINEVAR,"DATA")
+21 IF $DATA(VALMDDF("3RDCOL"))
SET LINEVAR=$$SETFLD^VALM1(VALUE3RDCOL,LINEVAR,"3RDCOL")
KILL VALMDDF("3RDCOL")
+22 SET VALMCNT=VALMCNT+1
DO SET^VALM10(VALMCNT,LINEVAR)
+23 QUIT
+24 ;
GETVALMDDF(LISTNAME,VALMDDF) ;EP GET VALMDDF FIELD DEF ARRAY
+1 ;
+2 if $GET(LISTNAME)=""
QUIT
+3 NEW I,LISTIEN
+4 SET LISTIEN=$ORDER(^SD(409.61,"B",LISTNAME,""))
+5 ;I LISTIEN="" W !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!" S ABORT=1 Q
+6 ;XINDEX MJL
IF LISTIEN=""
WRITE !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!"
QUIT
+7 ;SET UP COLUMN DATA ARRAY
SET I=0
+8 FOR
SET I=$ORDER(^SD(409.61,LISTIEN,"COL",I))
if 'I
QUIT
IF $DATA(^(I,0))
SET VALMDDF($PIECE(^(0),U))=^(0)
+9 QUIT
