IBOEMP1 ;ALB/ARH - EMPLOYER REPORT (SEARCH) ; 6/19/92
;;2.0;INTEGRATED BILLING;**91,746**;21-MAR-94;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
I IBCH="OPT" G OPT
;
INPT ;search for inpatient admissions (patient movement file)
S IBB=IBBEG-.001,IBE=IBEND+.3,IBHDR=IBHDR_" FOR INPATIENT ADMISSIONS ",IBQ=0
F S IBB=$O(^DGPM("AMV1",IBB)) Q:'IBB!(IBB>IBE)!(IBQ) D S IBQ=$$STOP^IBOEMP2
. S IBDFN="" F S IBDFN=$O(^DGPM("AMV1",IBB,IBDFN)) Q:'IBDFN D
.. Q:$D(^TMP("IBEMP",$J,IBDFN)) S Y=IBB D DD^%DT S IBAPDT=$P(Y,"@",1),IBPM=""
.. F S IBPM=$O(^DGPM("AMV1",IBB,IBDFN,IBPM)) Q:IBPM="" S IBAPTYP=$P(^DGPM(IBPM,0),"^",2),IBAPTYP=$P($G(^DG(405.3,IBAPTYP,0)),"^",1)
.. S IBAPDT=IBAPDT D PAT
K IBB,IBE,IBDFN,IBAPDT,IBAPTYP,IBPM,X,Y
Q
;
OPT ;search for outpatient visits (outpatient encounter file)
;find ALL outpatient visits within the date range and division
;includes registrations, scheduled appts, and unscheduled appointments
;
N IBVAL,IBCBK,IBCK,IBFILTER,IBOE,IBOE0,IBZ,IBPB
S IBVAL("BDT")=IBBEG,IBVAL("EDT")=IBEND+.3
; Only parent encounters, only extract info once per patient, only
; originating processes of disposition, add/edit and appts, only for selected divisions
S IBFILTER=""
S IBCBK="I '$P(Y0,U,6),'$D(^TMP(""IBEMP"",$J,+$P(Y0,U,2))),$P(Y0,U,8)'>3,$S(VAUTD=1:1,1:$D(VAUTD(+$P(Y0,U,11)))) S:$$STOP^IBOEMP2 (IBQ,SDSTOP)=1 I 'IBQ,$$BILLCK^IBAMTEDU(Y,Y0,.IBCK) D OPTENC^IBOEMP1(Y,Y0)"
S IBHDR=IBHDR_" FOR OUTPATIENT VISITS ",IBQ=0
F IBZ=9,13.1 S IBCK(IBZ)=""
D SCAN^IBSDU("DATE/TIME",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
;
K IBB,IBE,IBX,IBY,IBCLN,IBXP,IBDFN,IBAPDT,IBAPTYP,X,Y
Q
;
OPTENC(IBOE,IBOE0) ; Extract data for outpt encounter
N IBTYP
S IBB=+IBOE0,IBDFN=+$P(IBOE0,U,2),IBTYP=$P(IBOE0,U,8)
S Y=IBB D DD^%DT S IBAPDT=$P(Y,"@",1)
S IBAPTYP=$S(IBTYP<3:$P($G(^SD(409.1,+$P(IBOE0,U,10),0)),U),1:"DISPOSITION")
D PAT
Q
;
PAT ;gather data on patients with no insurance at time of care
;Input: IBB,IBDFN,IBAPTYP,IBAPDT
N IBX,IBY
I $D(^TMP("IBEMP",$J,IBDFN)) G PEND ; quit if this patient has already been processed
S ^TMP("IBEMP",$J,IBDFN)="" ; once a pt is checked don't check again
S DFN=IBDFN,IBINDT=IBB D ^IBCNS G:IBINS PEND ; quit if patient has insurance
D DEM^VADPT G:+VADM(6) PEND ; quit if patient is dead
D ELIG^VADPT S IBPELG=$G(^DIC(8,+VAEL(1),0)),IBPELG=$S($P(IBPELG,"^",3)'="":$P(IBPELG,"^",3),1:$E($P(VAEL(1),"^",2),1,4)) K VAEL
D OPD^VADPT S IBSES=$P($G(^DPT(DFN,.25)),"^",15) ; spouses employment status
;
;get patient and spouse's employer data
;add to report if patient or spouse employment status is employed or the patients or spouse employer name is defined
S DFN=IBDFN F Z=5,6 S VAOA("A")=Z D OAD^VADPT I VAOA(9)'=""!(Z=5&("1245"[+VAPD(7)))!(Z=6&("1245"[+IBSES)) D K VAOA
. S IBZ=$S(VAOA("A")=5:"P",1:"S"),IBADD="",IBADDN=VAOA(9),VAOA(5)=$P(VAOA(5),"^",2),IBX=0
. S IBY=$A(IBADDN) I IBY>96,IBY<123 S IBY=IBY-82 ; deal with lower case
. I IBY<IBRGB!(IBY>IBRGE) Q ; is employer name within range?
. I IBADDN="" S (VAOA(9),IBADDN)="{EMPLOYER NOT SPECIFIED}"
. F IBI=9,1:1:6,8 S IBX=IBX+1 I VAOA(IBI)'="" S $P(IBADD,"^",IBX)=VAOA(IBI)
. S IBY="",IBX=1
. I $D(^TMP("IBEMP",$J,"E",IBADDN)) F S IBY=$O(^TMP("IBEMP",$J,"E",IBADDN,IBY)) Q:IBY="" Q:^TMP("IBEMP",$J,"E",IBADDN,IBY)=IBADD S IBX=IBX+1
. S ^TMP("IBEMP",$J,"E",IBADDN)=+$G(^TMP("IBEMP",$J,"E",IBADDN))+1
. S ^TMP("IBEMP",$J,"E",IBADDN,IBX)=IBADD
. S ^TMP("IBEMP",$J,"E",IBADDN,IBX,VADM(1),IBDFN,IBZ)=""
. S ^TMP("IBEMP",$J,IBDFN)=VADM(1)_"^"_$P(VADM(3),U,2)_"^"_IBAPDT_"^"_IBAPTYP_"^"_IBPELG ;IB*2.0*746
. I IBZ="P" D OPD^VADPT S ^TMP("IBEMP",$J,IBDFN,IBZ)=VADM(1)_"^"_VAPD(6)_"^"_$P(IBES,"^",+VAPD(7))_"^"_$P(VADM(3),"^",2) Q
. D GETREL^DGMTU11(DFN,IBZ,IBEND) S IBY=$G(DGREL("S"))
. S ^TMP("IBEMP",$J,IBDFN,IBZ)=$$NAME^DGMTU1(+IBY)_"^"_$P($G(^DPT(DFN,.25)),"^",14)_"^"_$P(IBES,"^",+IBSES)_"^"_$$DOB^DGMTU1(+IBY) ;IB*2.0*746
PEND K VAIP,VADM,VAEL,VAPD,VAOA,DGREL,IBINDT,IBINS,DFN,IBPELG,IBSES,IBPAT,IBADD,IBADDN,IBI,IBX,IBY,IBZ,Z
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOEMP1 4089 printed Sep 23, 2025@20:01:48 Page 2
IBOEMP1 ;ALB/ARH - EMPLOYER REPORT (SEARCH) ; 6/19/92
+1 ;;2.0;INTEGRATED BILLING;**91,746**;21-MAR-94;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 IF IBCH="OPT"
GOTO OPT
+5 ;
INPT ;search for inpatient admissions (patient movement file)
+1 SET IBB=IBBEG-.001
SET IBE=IBEND+.3
SET IBHDR=IBHDR_" FOR INPATIENT ADMISSIONS "
SET IBQ=0
+2 FOR
SET IBB=$ORDER(^DGPM("AMV1",IBB))
if 'IBB!(IBB>IBE)!(IBQ)
QUIT
Begin DoDot:1
+3 SET IBDFN=""
FOR
SET IBDFN=$ORDER(^DGPM("AMV1",IBB,IBDFN))
if 'IBDFN
QUIT
Begin DoDot:2
+4 if $DATA(^TMP("IBEMP",$JOB,IBDFN))
QUIT
SET Y=IBB
DO DD^%DT
SET IBAPDT=$PIECE(Y,"@",1)
SET IBPM=""
+5 FOR
SET IBPM=$ORDER(^DGPM("AMV1",IBB,IBDFN,IBPM))
if IBPM=""
QUIT
SET IBAPTYP=$PIECE(^DGPM(IBPM,0),"^",2)
SET IBAPTYP=$PIECE($GET(^DG(405.3,IBAPTYP,0)),"^",1)
+6 SET IBAPDT=IBAPDT
DO PAT
End DoDot:2
End DoDot:1
SET IBQ=$$STOP^IBOEMP2
+7 KILL IBB,IBE,IBDFN,IBAPDT,IBAPTYP,IBPM,X,Y
+8 QUIT
+9 ;
OPT ;search for outpatient visits (outpatient encounter file)
+1 ;find ALL outpatient visits within the date range and division
+2 ;includes registrations, scheduled appts, and unscheduled appointments
+3 ;
+4 NEW IBVAL,IBCBK,IBCK,IBFILTER,IBOE,IBOE0,IBZ,IBPB
+5 SET IBVAL("BDT")=IBBEG
SET IBVAL("EDT")=IBEND+.3
+6 ; Only parent encounters, only extract info once per patient, only
+7 ; originating processes of disposition, add/edit and appts, only for selected divisions
+8 SET IBFILTER=""
+9 SET IBCBK="I '$P(Y0,U,6),'$D(^TMP(""IBEMP"",$J,+$P(Y0,U,2))),$P(Y0,U,8)'>3,$S(VAUTD=1:1,1:$D(VAUTD(+$P(Y0,U,11)))) S:$$STOP^IBOEMP2 (IBQ,SDSTOP)=1 I 'IBQ,$$BILLCK^IBAMTEDU(Y,Y0,.IBCK) D OPTENC^IBOEMP1(Y,Y0)"
+10 SET IBHDR=IBHDR_" FOR OUTPATIENT VISITS "
SET IBQ=0
+11 FOR IBZ=9,13.1
SET IBCK(IBZ)=""
+12 DO SCAN^IBSDU("DATE/TIME",.IBVAL,IBFILTER,IBCBK,1)
KILL ^TMP("DIERR",$JOB)
+13 ;
+14 KILL IBB,IBE,IBX,IBY,IBCLN,IBXP,IBDFN,IBAPDT,IBAPTYP,X,Y
+15 QUIT
+16 ;
OPTENC(IBOE,IBOE0) ; Extract data for outpt encounter
+1 NEW IBTYP
+2 SET IBB=+IBOE0
SET IBDFN=+$PIECE(IBOE0,U,2)
SET IBTYP=$PIECE(IBOE0,U,8)
+3 SET Y=IBB
DO DD^%DT
SET IBAPDT=$PIECE(Y,"@",1)
+4 SET IBAPTYP=$SELECT(IBTYP<3:$PIECE($GET(^SD(409.1,+$PIECE(IBOE0,U,10),0)),U),1:"DISPOSITION")
+5 DO PAT
+6 QUIT
+7 ;
PAT ;gather data on patients with no insurance at time of care
+1 ;Input: IBB,IBDFN,IBAPTYP,IBAPDT
+2 NEW IBX,IBY
+3 ; quit if this patient has already been processed
IF $DATA(^TMP("IBEMP",$JOB,IBDFN))
GOTO PEND
+4 ; once a pt is checked don't check again
SET ^TMP("IBEMP",$JOB,IBDFN)=""
+5 ; quit if patient has insurance
SET DFN=IBDFN
SET IBINDT=IBB
DO ^IBCNS
if IBINS
GOTO PEND
+6 ; quit if patient is dead
DO DEM^VADPT
if +VADM(6)
GOTO PEND
+7 DO ELIG^VADPT
SET IBPELG=$GET(^DIC(8,+VAEL(1),0))
SET IBPELG=$SELECT($PIECE(IBPELG,"^",3)'="":$PIECE(IBPELG,"^",3),1:$EXTRACT($PIECE(VAEL(1),"^",2),1,4))
KILL VAEL
+8 ; spouses employment status
DO OPD^VADPT
SET IBSES=$PIECE($GET(^DPT(DFN,.25)),"^",15)
+9 ;
+10 ;get patient and spouse's employer data
+11 ;add to report if patient or spouse employment status is employed or the patients or spouse employer name is defined
+12 SET DFN=IBDFN
FOR Z=5,6
SET VAOA("A")=Z
DO OAD^VADPT
IF VAOA(9)'=""!(Z=5&("1245"[+VAPD(7)))!(Z=6&("1245"[+IBSES))
Begin DoDot:1
+13 SET IBZ=$SELECT(VAOA("A")=5:"P",1:"S")
SET IBADD=""
SET IBADDN=VAOA(9)
SET VAOA(5)=$PIECE(VAOA(5),"^",2)
SET IBX=0
+14 ; deal with lower case
SET IBY=$ASCII(IBADDN)
IF IBY>96
IF IBY<123
SET IBY=IBY-82
+15 ; is employer name within range?
IF IBY<IBRGB!(IBY>IBRGE)
QUIT
+16 IF IBADDN=""
SET (VAOA(9),IBADDN)="{EMPLOYER NOT SPECIFIED}"
+17 FOR IBI=9,1:1:6,8
SET IBX=IBX+1
IF VAOA(IBI)'=""
SET $PIECE(IBADD,"^",IBX)=VAOA(IBI)
+18 SET IBY=""
SET IBX=1
+19 IF $DATA(^TMP("IBEMP",$JOB,"E",IBADDN))
FOR
SET IBY=$ORDER(^TMP("IBEMP",$JOB,"E",IBADDN,IBY))
if IBY=""
QUIT
if ^TMP("IBEMP",$JOB,"E",IBADDN,IBY)=IBADD
QUIT
SET IBX=IBX+1
+20 SET ^TMP("IBEMP",$JOB,"E",IBADDN)=+$GET(^TMP("IBEMP",$JOB,"E",IBADDN))+1
+21 SET ^TMP("IBEMP",$JOB,"E",IBADDN,IBX)=IBADD
+22 SET ^TMP("IBEMP",$JOB,"E",IBADDN,IBX,VADM(1),IBDFN,IBZ)=""
+23 ;IB*2.0*746
SET ^TMP("IBEMP",$JOB,IBDFN)=VADM(1)_"^"_$PIECE(VADM(3),U,2)_"^"_IBAPDT_"^"_IBAPTYP_"^"_IBPELG
+24 IF IBZ="P"
DO OPD^VADPT
SET ^TMP("IBEMP",$JOB,IBDFN,IBZ)=VADM(1)_"^"_VAPD(6)_"^"_$PIECE(IBES,"^",+VAPD(7))_"^"_$PIECE(VADM(3),"^",2)
QUIT
+25 DO GETREL^DGMTU11(DFN,IBZ,IBEND)
SET IBY=$GET(DGREL("S"))
+26 ;IB*2.0*746
SET ^TMP("IBEMP",$JOB,IBDFN,IBZ)=$$NAME^DGMTU1(+IBY)_"^"_$PIECE($GET(^DPT(DFN,.25)),"^",14)_"^"_$PIECE(IBES,"^",+IBSES)_"^"_$$DOB^DGMTU1(+IBY)
End DoDot:1
KILL VAOA
PEND KILL VAIP,VADM,VAEL,VAPD,VAOA,DGREL,IBINDT,IBINS,DFN,IBPELG,IBSES,IBPAT,IBADD,IBADDN,IBI,IBX,IBY,IBZ,Z
+1 QUIT
