IBFBWL2 ;ALB/PAW-IB BILLING Worklist Expand Item ;30-SEP-2015
;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for BILLING WORKLIST EXPAND
D EN^VALM("IB PRECERT WORKLIST EXPAND")
Q
;
HDR ; -- header code
S VALM("TITLE")=" Expanded NVC"
Q
;
INIT ; -- init variables and list array
; input - ^TMP("IBFBWE",$J)=DFN^IBNAME^IBAUTH
; output - Expanded worklist screen
I '$D(^TMP("IBFBWE",$J)) Q
N CNT,DFN,ECNT,IBFBA,IBNAME,IBAUTH,IBST,LINE,VAEL
S ECNT=$G(^TMP("IBFBWE",$J))
S DFN=$P(ECNT,U,1),IBNAME=$P(ECNT,U,2),IBAUTH=$P(ECNT,U,3),IBFBA=$P(ECNT,U,4)
D BLD
D GETSC
D GETSTA
D GETINS
D BLDEXP
S VALMBCK="R"
Q
;
BLD ; build data to display
N IBARRAY,IB7078,IBCP,IBFBCPT,IBFBCPTD,IBIEN,IBDX1,IBDX2,IBDX3,IBEND,IBENDX,IBFILL,IBFP,IBFPNO,IBICDDX,IBICDDXD,IBINV,IBINVPD,IBMT,IBFPNOT,IBPAYX,IBNPI
N IBPUR,IBREF,IBREFA,IBREM,IBREM1,IBREMARK,IBRET,IBSS,IBSTX,IBTAX,IBVND,IBVNDA,IBVNPI,IBSSX,IBSSLE
N IBSSLS,IBVTAX,IBX,IBXX,VA,IBDIV,IBDIV2,IBSTNUM
S CNT=0
D ELIG^VADPT
S IBSSX=$$GET1^DIQ(2,DFN_",",.09,"I"),IBSSLE=$L(IBSSX),IBSSLS=6 I $E(IBSSX,IBSSLE)="P" S IBSSLS=5
S IBSS=$E(IBNAME,1)_$E(IBSSX,IBSSLS,IBSSLE)
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="PATIENT : "_IBNAME_" (ID: "_IBSS_")"
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="SSN : "_IBSSX
S IBIEN=IBAUTH_","_DFN_","
S IBDIV=$$GET1^DIQ(161.01,IBIEN_",",101,"E")
S IBDIV2=$$GET1^DIQ(161.01,IBIEN_",",101,"I")
S IBSTNUM=$$GET1^DIQ(4,IBDIV2_",",99,"E")
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="DIVISION : "_IBDIV_" - "_IBSTNUM
D GETAUTH^IBFBUTIL(IBIEN,"IBARRAY") ; Call API for Authorization Sub-File (#161.01) fields
I IBWLTYP="P" D
. S IBST=$G(IBARRAY(161.01,IBIEN,.01,"I"))
. S IBEND=$G(IBARRAY(161.01,IBIEN,.02,"I"))
. S IBSTX=$G(IBARRAY(161.01,IBIEN,.01,"E"))
. S IBENDX=$G(IBARRAY(161.01,IBIEN,.02,"E"))
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="AUTH DOS RANGE : "_IBSTX_" - "_IBENDX
I IBWLTYP="B" D
. S (IBST,IBINV)=""
. I IBFBA'="" S IBXX=IBFBA
. I IBFBA="" D
.. S IBX="" F S IBX=$O(^IBFB(360,"C",DFN,IBX)) Q:IBX="" D
... I $$GET1^DIQ(360,IBX_",",.03)=IBAUTH S IBXX=IBX
. D GETST^IBFBUTIL(IBXX)
. D GETPAY^IBFBUTIL(IBXX)
. I IBST'="" S IBSTX=$$FDATE^VALM1(IBST)
. I $G(IBFPNOT)="CIVIL HOSPITAL" S IBFPNOT=IBFPNOT_" (INPATIENT)"
. I $G(IBFPNOT)="CONTRACT NURSING HOME" S IBFPNOT=IBFPNOT_" (SKILLED NURSING FACILIY)"
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="INVOICE NVC : "_$G(IBFPNOT)
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="INVOICE# : "_IBINV
. I IBFPNO=2!(IBFPNO=3) S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="SERVICE DATE : "_$G(IBSTX)
. I IBFPNO=6!(IBFPNO=7) S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="DOS START DATE : "_$G(IBSTX)
. ; I IBFPNO=3 S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="VENDOR : "_$G(IBVNDA)
. I $G(IBINV)'="" D
.. S IBPAYX=""
.. F S IBPAYX=$O(IBRET(162.03,IBPAYX)) Q:IBPAYX="" D
... I $G(IBRET(162.03,IBPAYX,.01,"I"))'="",IBST'="" D ; Short description of CPT
.... S IBFBCPT=IBRET(162.03,IBPAYX,.01,"I")
.... S IBFBCPTD=$$CPT^ICPTCOD(IBFBCPT,$S($G(IBST)>0:+$G(IBST),1:""),1)
.... I IBFBCPTD'="" S IBFBCPT=$P(IBFBCPTD,U,2)_" - "_$P(IBFBCPTD,U,3)
... ; S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" SERVICE CPT : "_$G(IBRET(162.03,IBPAYX,.01,"I"))
... S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" SERVICE CPT : "_$G(IBFBCPT)
... I $D(IBRET(162.03,IBPAYX,2,"I")) S IBINVPD=$FN(IBRET(162.03,IBPAYX,2,"I"),"",2)
... S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" AMOUNT PAID : "_$G(IBINVPD)
... S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" RENDERING PROV : "_$G(IBRET(162.03,IBPAYX,63,"I"))
... S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" RENDERING NPI : "_$G(IBRET(162.03,IBPAYX,64,"I"))
... S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" RENDERING TAX : "_$G(IBRET(162.03,IBPAYX,65,"I"))
S IBFP=$G(IBARRAY(161.01,IBIEN,.03,"E"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="AUTHORIZATION NVC : "_IBFP
S IBPUR=$G(IBARRAY(161.01,IBIEN,.07,"E"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="PURPOSE OF VISIT : "_IBPUR
S IBVND=$G(IBARRAY(161.01,IBIEN,.04,"E"))
S IBVNDA=$G(IBARRAY(161.01,IBIEN,.04,"I"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="NON-VA LOCATION : "_IBVND
S IBVNPI=""
I IBVNDA'="" S IBVNPI=$$GET1^DIQ(161.2,IBVNDA_",",41.01)
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" NPI# : "_IBVNPI
S IBVTAX=""
I IBVNDA'="" S IBVTAX=$$GET1^DIQ(161.2,IBVNDA_",",42)
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" TAXONOMY : "_IBVTAX
S IB7078=$G(IBARRAY(161.01,IBIEN,.055,"E"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="ASSOC 7078/583 : "_IB7078
S IBREF=$G(IBARRAY(161.01,IBIEN,104,"E"))
S IBREFA=$G(IBARRAY(161.01,IBIEN,104,"I"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="ORDERING PHYSICIAN: "_IBREF
S IBNPI=""
I IBREFA'="" S IBNPI=$$GET1^DIQ(200,IBREFA_",",41.99)
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" NPI# : "_IBNPI
; Placeholder if VA starts to use Taxonomy for VA physicians
S IBTAX=""
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" TAXONOMY : "_IBTAX
S IBMT=$P($G(VAEL(9)),U,2)
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="MEANS TEST STATUS : "_IBMT
D DISP^IBARXEU(DFN,IBST,1,"")
S IBCP=$P($G(X),U,2)
; S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="MED COPAY EXEMP ST: "_IBCP
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="RX COPAY EXEMP ST : "_IBCP
S IBDX1=$G(IBARRAY(161.01,IBIEN,.08,"E"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="DIAGNOSIS 1 : "_IBDX1
S IBDX2=$G(IBARRAY(161.01,IBIEN,.085,"E"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="DIAGNOSIS 2 : "_IBDX2
S IBDX3=$G(IBARRAY(161.01,IBIEN,.086,"E"))
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="DIAGNOSIS 3 : "_IBDX3
S IBICDDX=$G(IBARRAY(161.01,IBIEN,.087,"E"))
I $G(IBARRAY(161.01,IBIEN,.087,"I"))'="" D
. S IBICDDXD=$$ICDDATA^ICDXCODE("10D",IBARRAY(161.01,IBIEN,.087,"I"))
. S IBICDDXD=$P(IBICDDXD,U,4)
. I IBICDDXD="" D
.. S IBICDDXD=$$ICDDATA^ICDXCODE("ICD9",IBARRAY(161.01,IBIEN,.087,"I"),IBST)
.. S IBICDDXD=$P(IBICDDXD,U,4)
. I IBICDDXD'="" S IBICDDX=IBICDDX_" - "_IBICDDXD
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="ICD DIAGNOSIS : "_IBICDDX
I '$D(IBARRAY(161.01,IBIEN,.021)) S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="AUTH REMARKS : "
S IBREM="",IBREM1=1
F S IBREM=$O(IBARRAY(161.01,IBIEN,.021,IBREM)) Q:IBREM=""!(IBREM="E") D
. S IBREMARK=IBARRAY(161.01,IBIEN,.021,IBREM)
. I IBREM1 S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="AUTH REMARKS : "_IBREMARK,IBREM1=0
. E S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" : "_IBREMARK
Q
;
BLDEXP ; Build expand screen
D FULL^VALM1
N IBXX
S DFN=$P(ECNT,U,1),IBNAME=$P(ECNT,U,2),IBAUTH=$P(ECNT,U,3)
S VALMCNT=0
S IBXX=""
F S IBXX=$O(^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,IBXX)) Q:+IBXX=0 D
. S LINE=^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,IBXX)
. S VALMCNT=VALMCNT+1
. D SET^VALM10(VALMCNT,LINE,"")
S VALMCNT=VALMCNT+1
Q
;
GETSC ; Get SC and STA
N IBD,IBI,IBX,IBY,IBSC,IBSC1,FIRST
S FIRST=1
I VAEL(3)=0 S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="SERVICE CONNECTED : NO" Q
S IBSC="SERVICE CONNECTED : "_$P(VAEL(3),U,2)_"%"
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=IBSC
I '$O(^DPT(DFN,.372,0)) S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="RATED DISABILITIES: NONE" Q
S IBI=0 F S IBI=$O(^DPT(DFN,.372,IBI)) Q:'IBI D
. S IBX=$G(^DPT(DFN,.372,IBI,0)),IBY=$G(^DIC(31,+IBX,0))
. S IBD=$S($P(IBY,U,4)="":$P(IBY,U,1),1:$P(IBY,U,4))_" ("_$P(IBX,U,2)_"%-"_$S(+$P(IBX,U,3):"SC",1:"NSC")_")"
. I FIRST S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="RATED DISABILITIES: "_IBD,FIRST=0 Q
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" "_IBD
Q
;
GETSTA ; Get Special Authority Eligibility
N IBY,FIRST,FOUND,IBADT,IBARR
S IBADT=IBST
S FOUND=0
S FIRST=1
D CL^IBACV(DFN,IBADT,"",.IBARR)
I $D(IBARR(3)) S IBY="SC TREATMENT" D GETSTA1
I $D(IBARR(7)),+$$CVEDT^IBACV(DFN,IBADT) S IBY="COMBAT VETERAN" D GETSTA1
I $D(IBARR(1)) S IBY="AGENT ORANGE" D GETSTA1
I $D(IBARR(2)) S IBY="IONIZING RADIATION" D GETSTA1
I $D(IBARR(4)) S IBY="SOUTHWEST ASIA" D GETSTA1
I $D(IBARR(8)) S IBY="PROJECT 112/SHAD" D GETSTA1
I $D(IBARR(5)) S IBY="MILITARY SEXUAL TRAUMA" D GETSTA1
I $D(IBARR(6)) S IBY="HEAD/NECK CANCER" D GETSTA1
I 'FOUND S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="SPECIAL AUTHORITY : NO" Q
Q
;
GETSTA1 ; Set in ^TMP("IBFBWE",$J)
I FIRST S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="SPECIAL AUTHORITY : "_IBY,FIRST=0,FOUND=1 Q
S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" : "_IBY
Q
;
GETINS ; Get insurance information
N EXDTCK,IBEFF,IBEXP,IBGRP,IBINSCO,IBINS0,IBINS1,IBINS7,IBSUB,IBVERBY,IBVERDT,IBX,IBINS,IBINSYES
D ALL^IBCNS1(DFN,"IBINS")
S (IBX,IBINSYES)=0
I '$D(IBINS) S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="INSURANCE : NO" Q
F S IBX=$O(IBINS(IBX)) Q:'IBX D
. S IBINS0=IBINS(IBX,0)
. S IBINS1=IBINS(IBX,1)
. S IBINS7=$G(IBINS(IBX,7))
. S IBINSCO=$P(^DIC(36,+IBINS0,0),U,1)
. S IBSUB=$P(IBINS7,U,1)
. S IBGRP=$P(IBINS0,U,3)
. S EXDTCK=+$P(IBINS0,U,4)
. I EXDTCK,EXDTCK<IBST Q ; if insurance expired before the from date of auth quit
. S IBINSYES=1
. S IBEFF=$$DAT1^IBOUTL($P(IBINS0,U,8))
. S IBEXP=$$DAT1^IBOUTL($P(IBINS0,U,4))
. S IBVERDT=$P($G(IBINS1),U,3)
. S IBVERBY=$P($G(IBINS1),U,4)
. I IBVERDT'="" S IBVERDT=$$FDATE^VALM1(IBVERDT)
. I IBVERBY'="" S IBVERBY="BY "_$$GET1^DIQ(200,IBVERBY_", ",.01)
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="INSURANCE : "_IBINSCO
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" SUBSCRIBER : "_IBSUB
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" GROUP : "_IBGRP
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" EFF DATE : "_IBEFF
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" EXP DATE : "_IBEXP
. S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" DT LAST VERIF : "_IBVERDT_" "_IBVERBY
I IBINSYES=0 S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="INSURANCE : NO"
Q
;
REFRESH ; Special Expand Screen Refresh
K ^TMP("IBFBWE",$J)
D BLD
D GETSC
D GETSTA
D GETINS
D BLDEXP
S VALMBCK="R"
Q
;
HELP ; -- help code
N X
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBFBWE",$J)
D ^%ZISC
S VALMBCK="R" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBFBWL2 11007 printed Apr 09, 2024@21:06:05 Page 2
IBFBWL2 ;ALB/PAW-IB BILLING Worklist Expand Item ;30-SEP-2015
+1 ;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for BILLING WORKLIST EXPAND
+1 DO EN^VALM("IB PRECERT WORKLIST EXPAND")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALM("TITLE")=" Expanded NVC"
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 ; input - ^TMP("IBFBWE",$J)=DFN^IBNAME^IBAUTH
+2 ; output - Expanded worklist screen
+3 IF '$DATA(^TMP("IBFBWE",$JOB))
QUIT
+4 NEW CNT,DFN,ECNT,IBFBA,IBNAME,IBAUTH,IBST,LINE,VAEL
+5 SET ECNT=$GET(^TMP("IBFBWE",$JOB))
+6 SET DFN=$PIECE(ECNT,U,1)
SET IBNAME=$PIECE(ECNT,U,2)
SET IBAUTH=$PIECE(ECNT,U,3)
SET IBFBA=$PIECE(ECNT,U,4)
+7 DO BLD
+8 DO GETSC
+9 DO GETSTA
+10 DO GETINS
+11 DO BLDEXP
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
BLD ; build data to display
+1 NEW IBARRAY,IB7078,IBCP,IBFBCPT,IBFBCPTD,IBIEN,IBDX1,IBDX2,IBDX3,IBEND,IBENDX,IBFILL,IBFP,IBFPNO,IBICDDX,IBICDDXD,IBINV,IBINVPD,IBMT,IBFPNOT,IBPAYX,IBNPI
+2 NEW IBPUR,IBREF,IBREFA,IBREM,IBREM1,IBREMARK,IBRET,IBSS,IBSTX,IBTAX,IBVND,IBVNDA,IBVNPI,IBSSX,IBSSLE
+3 NEW IBSSLS,IBVTAX,IBX,IBXX,VA,IBDIV,IBDIV2,IBSTNUM
+4 SET CNT=0
+5 DO ELIG^VADPT
+6 SET IBSSX=$$GET1^DIQ(2,DFN_",",.09,"I")
SET IBSSLE=$LENGTH(IBSSX)
SET IBSSLS=6
IF $EXTRACT(IBSSX,IBSSLE)="P"
SET IBSSLS=5
+7 SET IBSS=$EXTRACT(IBNAME,1)_$EXTRACT(IBSSX,IBSSLS,IBSSLE)
+8 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="PATIENT : "_IBNAME_" (ID: "_IBSS_")"
+9 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="SSN : "_IBSSX
+10 SET IBIEN=IBAUTH_","_DFN_","
+11 SET IBDIV=$$GET1^DIQ(161.01,IBIEN_",",101,"E")
+12 SET IBDIV2=$$GET1^DIQ(161.01,IBIEN_",",101,"I")
+13 SET IBSTNUM=$$GET1^DIQ(4,IBDIV2_",",99,"E")
+14 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="DIVISION : "_IBDIV_" - "_IBSTNUM
+15 ; Call API for Authorization Sub-File (#161.01) fields
DO GETAUTH^IBFBUTIL(IBIEN,"IBARRAY")
+16 IF IBWLTYP="P"
Begin DoDot:1
+17 SET IBST=$GET(IBARRAY(161.01,IBIEN,.01,"I"))
+18 SET IBEND=$GET(IBARRAY(161.01,IBIEN,.02,"I"))
+19 SET IBSTX=$GET(IBARRAY(161.01,IBIEN,.01,"E"))
+20 SET IBENDX=$GET(IBARRAY(161.01,IBIEN,.02,"E"))
+21 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="AUTH DOS RANGE : "_IBSTX_" - "_IBENDX
End DoDot:1
+22 IF IBWLTYP="B"
Begin DoDot:1
+23 SET (IBST,IBINV)=""
+24 IF IBFBA'=""
SET IBXX=IBFBA
+25 IF IBFBA=""
Begin DoDot:2
+26 SET IBX=""
FOR
SET IBX=$ORDER(^IBFB(360,"C",DFN,IBX))
if IBX=""
QUIT
Begin DoDot:3
+27 IF $$GET1^DIQ(360,IBX_",",.03)=IBAUTH
SET IBXX=IBX
End DoDot:3
End DoDot:2
+28 DO GETST^IBFBUTIL(IBXX)
+29 DO GETPAY^IBFBUTIL(IBXX)
+30 IF IBST'=""
SET IBSTX=$$FDATE^VALM1(IBST)
+31 IF $GET(IBFPNOT)="CIVIL HOSPITAL"
SET IBFPNOT=IBFPNOT_" (INPATIENT)"
+32 IF $GET(IBFPNOT)="CONTRACT NURSING HOME"
SET IBFPNOT=IBFPNOT_" (SKILLED NURSING FACILIY)"
+33 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="INVOICE NVC : "_$GET(IBFPNOT)
+34 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="INVOICE# : "_IBINV
+35 IF IBFPNO=2!(IBFPNO=3)
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="SERVICE DATE : "_$GET(IBSTX)
+36 IF IBFPNO=6!(IBFPNO=7)
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="DOS START DATE : "_$GET(IBSTX)
+37 ; I IBFPNO=3 S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="VENDOR : "_$G(IBVNDA)
+38 IF $GET(IBINV)'=""
Begin DoDot:2
+39 SET IBPAYX=""
+40 FOR
SET IBPAYX=$ORDER(IBRET(162.03,IBPAYX))
if IBPAYX=""
QUIT
Begin DoDot:3
+41 ; Short description of CPT
IF $GET(IBRET(162.03,IBPAYX,.01,"I"))'=""
IF IBST'=""
Begin DoDot:4
+42 SET IBFBCPT=IBRET(162.03,IBPAYX,.01,"I")
+43 SET IBFBCPTD=$$CPT^ICPTCOD(IBFBCPT,$SELECT($GET(IBST)>0:+$GET(IBST),1:""),1)
+44 IF IBFBCPTD'=""
SET IBFBCPT=$PIECE(IBFBCPTD,U,2)_" - "_$PIECE(IBFBCPTD,U,3)
End DoDot:4
+45 ; S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)=" SERVICE CPT : "_$G(IBRET(162.03,IBPAYX,.01,"I"))
+46 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" SERVICE CPT : "_$GET(IBFBCPT)
+47 IF $DATA(IBRET(162.03,IBPAYX,2,"I"))
SET IBINVPD=$FNUMBER(IBRET(162.03,IBPAYX,2,"I"),"",2)
+48 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" AMOUNT PAID : "_$GET(IBINVPD)
+49 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" RENDERING PROV : "_$GET(IBRET(162.03,IBPAYX,63,"I"))
+50 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" RENDERING NPI : "_$GET(IBRET(162.03,IBPAYX,64,"I"))
+51 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" RENDERING TAX : "_$GET(IBRET(162.03,IBPAYX,65,"I"))
End DoDot:3
End DoDot:2
End DoDot:1
+52 SET IBFP=$GET(IBARRAY(161.01,IBIEN,.03,"E"))
+53 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="AUTHORIZATION NVC : "_IBFP
+54 SET IBPUR=$GET(IBARRAY(161.01,IBIEN,.07,"E"))
+55 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="PURPOSE OF VISIT : "_IBPUR
+56 SET IBVND=$GET(IBARRAY(161.01,IBIEN,.04,"E"))
+57 SET IBVNDA=$GET(IBARRAY(161.01,IBIEN,.04,"I"))
+58 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="NON-VA LOCATION : "_IBVND
+59 SET IBVNPI=""
+60 IF IBVNDA'=""
SET IBVNPI=$$GET1^DIQ(161.2,IBVNDA_",",41.01)
+61 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" NPI# : "_IBVNPI
+62 SET IBVTAX=""
+63 IF IBVNDA'=""
SET IBVTAX=$$GET1^DIQ(161.2,IBVNDA_",",42)
+64 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" TAXONOMY : "_IBVTAX
+65 SET IB7078=$GET(IBARRAY(161.01,IBIEN,.055,"E"))
+66 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="ASSOC 7078/583 : "_IB7078
+67 SET IBREF=$GET(IBARRAY(161.01,IBIEN,104,"E"))
+68 SET IBREFA=$GET(IBARRAY(161.01,IBIEN,104,"I"))
+69 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="ORDERING PHYSICIAN: "_IBREF
+70 SET IBNPI=""
+71 IF IBREFA'=""
SET IBNPI=$$GET1^DIQ(200,IBREFA_",",41.99)
+72 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" NPI# : "_IBNPI
+73 ; Placeholder if VA starts to use Taxonomy for VA physicians
+74 SET IBTAX=""
+75 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" TAXONOMY : "_IBTAX
+76 SET IBMT=$PIECE($GET(VAEL(9)),U,2)
+77 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="MEANS TEST STATUS : "_IBMT
+78 DO DISP^IBARXEU(DFN,IBST,1,"")
+79 SET IBCP=$PIECE($GET(X),U,2)
+80 ; S CNT=CNT+1,^TMP("IBFBWE",$J,IBNAME,DFN,IBAUTH,CNT)="MED COPAY EXEMP ST: "_IBCP
+81 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="RX COPAY EXEMP ST : "_IBCP
+82 SET IBDX1=$GET(IBARRAY(161.01,IBIEN,.08,"E"))
+83 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="DIAGNOSIS 1 : "_IBDX1
+84 SET IBDX2=$GET(IBARRAY(161.01,IBIEN,.085,"E"))
+85 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="DIAGNOSIS 2 : "_IBDX2
+86 SET IBDX3=$GET(IBARRAY(161.01,IBIEN,.086,"E"))
+87 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="DIAGNOSIS 3 : "_IBDX3
+88 SET IBICDDX=$GET(IBARRAY(161.01,IBIEN,.087,"E"))
+89 IF $GET(IBARRAY(161.01,IBIEN,.087,"I"))'=""
Begin DoDot:1
+90 SET IBICDDXD=$$ICDDATA^ICDXCODE("10D",IBARRAY(161.01,IBIEN,.087,"I"))
+91 SET IBICDDXD=$PIECE(IBICDDXD,U,4)
+92 IF IBICDDXD=""
Begin DoDot:2
+93 SET IBICDDXD=$$ICDDATA^ICDXCODE("ICD9",IBARRAY(161.01,IBIEN,.087,"I"),IBST)
+94 SET IBICDDXD=$PIECE(IBICDDXD,U,4)
End DoDot:2
+95 IF IBICDDXD'=""
SET IBICDDX=IBICDDX_" - "_IBICDDXD
End DoDot:1
+96 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="ICD DIAGNOSIS : "_IBICDDX
+97 IF '$DATA(IBARRAY(161.01,IBIEN,.021))
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="AUTH REMARKS : "
+98 SET IBREM=""
SET IBREM1=1
+99 FOR
SET IBREM=$ORDER(IBARRAY(161.01,IBIEN,.021,IBREM))
if IBREM=""!(IBREM="E")
QUIT
Begin DoDot:1
+100 SET IBREMARK=IBARRAY(161.01,IBIEN,.021,IBREM)
+101 IF IBREM1
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="AUTH REMARKS : "_IBREMARK
SET IBREM1=0
+102 IF '$TEST
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" : "_IBREMARK
End DoDot:1
+103 QUIT
+104 ;
BLDEXP ; Build expand screen
+1 DO FULL^VALM1
+2 NEW IBXX
+3 SET DFN=$PIECE(ECNT,U,1)
SET IBNAME=$PIECE(ECNT,U,2)
SET IBAUTH=$PIECE(ECNT,U,3)
+4 SET VALMCNT=0
+5 SET IBXX=""
+6 FOR
SET IBXX=$ORDER(^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,IBXX))
if +IBXX=0
QUIT
Begin DoDot:1
+7 SET LINE=^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,IBXX)
+8 SET VALMCNT=VALMCNT+1
+9 DO SET^VALM10(VALMCNT,LINE,"")
End DoDot:1
+10 SET VALMCNT=VALMCNT+1
+11 QUIT
+12 ;
GETSC ; Get SC and STA
+1 NEW IBD,IBI,IBX,IBY,IBSC,IBSC1,FIRST
+2 SET FIRST=1
+3 IF VAEL(3)=0
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="SERVICE CONNECTED : NO"
QUIT
+4 SET IBSC="SERVICE CONNECTED : "_$PIECE(VAEL(3),U,2)_"%"
+5 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=IBSC
+6 IF '$ORDER(^DPT(DFN,.372,0))
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="RATED DISABILITIES: NONE"
QUIT
+7 SET IBI=0
FOR
SET IBI=$ORDER(^DPT(DFN,.372,IBI))
if 'IBI
QUIT
Begin DoDot:1
+8 SET IBX=$GET(^DPT(DFN,.372,IBI,0))
SET IBY=$GET(^DIC(31,+IBX,0))
+9 SET IBD=$SELECT($PIECE(IBY,U,4)="":$PIECE(IBY,U,1),1:$PIECE(IBY,U,4))_" ("_$PIECE(IBX,U,2)_"%-"_$SELECT(+$PIECE(IBX,U,3):"SC",1:"NSC")_")"
+10 IF FIRST
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="RATED DISABILITIES: "_IBD
SET FIRST=0
QUIT
+11 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" "_IBD
End DoDot:1
+12 QUIT
+13 ;
GETSTA ; Get Special Authority Eligibility
+1 NEW IBY,FIRST,FOUND,IBADT,IBARR
+2 SET IBADT=IBST
+3 SET FOUND=0
+4 SET FIRST=1
+5 DO CL^IBACV(DFN,IBADT,"",.IBARR)
+6 IF $DATA(IBARR(3))
SET IBY="SC TREATMENT"
DO GETSTA1
+7 IF $DATA(IBARR(7))
IF +$$CVEDT^IBACV(DFN,IBADT)
SET IBY="COMBAT VETERAN"
DO GETSTA1
+8 IF $DATA(IBARR(1))
SET IBY="AGENT ORANGE"
DO GETSTA1
+9 IF $DATA(IBARR(2))
SET IBY="IONIZING RADIATION"
DO GETSTA1
+10 IF $DATA(IBARR(4))
SET IBY="SOUTHWEST ASIA"
DO GETSTA1
+11 IF $DATA(IBARR(8))
SET IBY="PROJECT 112/SHAD"
DO GETSTA1
+12 IF $DATA(IBARR(5))
SET IBY="MILITARY SEXUAL TRAUMA"
DO GETSTA1
+13 IF $DATA(IBARR(6))
SET IBY="HEAD/NECK CANCER"
DO GETSTA1
+14 IF 'FOUND
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="SPECIAL AUTHORITY : NO"
QUIT
+15 QUIT
+16 ;
GETSTA1 ; Set in ^TMP("IBFBWE",$J)
+1 IF FIRST
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="SPECIAL AUTHORITY : "_IBY
SET FIRST=0
SET FOUND=1
QUIT
+2 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" : "_IBY
+3 QUIT
+4 ;
GETINS ; Get insurance information
+1 NEW EXDTCK,IBEFF,IBEXP,IBGRP,IBINSCO,IBINS0,IBINS1,IBINS7,IBSUB,IBVERBY,IBVERDT,IBX,IBINS,IBINSYES
+2 DO ALL^IBCNS1(DFN,"IBINS")
+3 SET (IBX,IBINSYES)=0
+4 IF '$DATA(IBINS)
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="INSURANCE : NO"
QUIT
+5 FOR
SET IBX=$ORDER(IBINS(IBX))
if 'IBX
QUIT
Begin DoDot:1
+6 SET IBINS0=IBINS(IBX,0)
+7 SET IBINS1=IBINS(IBX,1)
+8 SET IBINS7=$GET(IBINS(IBX,7))
+9 SET IBINSCO=$PIECE(^DIC(36,+IBINS0,0),U,1)
+10 SET IBSUB=$PIECE(IBINS7,U,1)
+11 SET IBGRP=$PIECE(IBINS0,U,3)
+12 SET EXDTCK=+$PIECE(IBINS0,U,4)
+13 ; if insurance expired before the from date of auth quit
IF EXDTCK
IF EXDTCK<IBST
QUIT
+14 SET IBINSYES=1
+15 SET IBEFF=$$DAT1^IBOUTL($PIECE(IBINS0,U,8))
+16 SET IBEXP=$$DAT1^IBOUTL($PIECE(IBINS0,U,4))
+17 SET IBVERDT=$PIECE($GET(IBINS1),U,3)
+18 SET IBVERBY=$PIECE($GET(IBINS1),U,4)
+19 IF IBVERDT'=""
SET IBVERDT=$$FDATE^VALM1(IBVERDT)
+20 IF IBVERBY'=""
SET IBVERBY="BY "_$$GET1^DIQ(200,IBVERBY_", ",.01)
+21 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="INSURANCE : "_IBINSCO
+22 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" SUBSCRIBER : "_IBSUB
+23 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" GROUP : "_IBGRP
+24 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" EFF DATE : "_IBEFF
+25 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" EXP DATE : "_IBEXP
+26 SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)=" DT LAST VERIF : "_IBVERDT_" "_IBVERBY
End DoDot:1
+27 IF IBINSYES=0
SET CNT=CNT+1
SET ^TMP("IBFBWE",$JOB,IBNAME,DFN,IBAUTH,CNT)="INSURANCE : NO"
+28 QUIT
+29 ;
REFRESH ; Special Expand Screen Refresh
+1 KILL ^TMP("IBFBWE",$JOB)
+2 DO BLD
+3 DO GETSC
+4 DO GETSTA
+5 DO GETINS
+6 DO BLDEXP
+7 SET VALMBCK="R"
+8 QUIT
+9 ;
HELP ; -- help code
+1 NEW X
+2 SET X="?"
DO DISP^XQORM1
WRITE !!
+3 QUIT
+4 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBFBWE",$JOB)
+2 DO ^%ZISC
+3 SET VALMBCK="R"
QUIT
+4 QUIT
