IBOEMP2 ;ALB/ARH - EMPLOYER REPORT (PRINT) ; 6/19/93
;;2.0;INTEGRATED BILLING;**91,746**; 21-MAR-94;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
;Array: patient: DFN)=pt name ^ SSN ^ event date ^ appt type ^ prim elig
; employed: DFN,x)=name ^ occupation ^ employment status ^ SSN
; employer: "E",EMPLOYER NAME)=count of employees per employer name
; "E",EMPLOYER NAME,y)=employer address
; "E",EMPLOYER NAME,y,PATIENT NAME,DFN,x)=""
;
; w/x = "P" if employed is patient, "S" for spouse otherwise
; y = number of employers with same name but not the same address, ie. 1:1:...
;
;
D HDR
;
P1 ;print report
Q:'$D(^TMP("IBEMP",$J)) S IBW=IOM
S IBADDN="" F S IBADDN=$O(^TMP("IBEMP",$J,"E",IBADDN)) Q:IBADDN=""!(IBQ) S IBCNT=^TMP("IBEMP",$J,"E",IBADDN),IBX="" D Q:IBQ
. F S IBX=$O(^TMP("IBEMP",$J,"E",IBADDN,IBX)) Q:IBX=""!(IBQ) D:(IBLN+9)>IOSL HDR Q:IBQ D W !!,IBDSH,! S IBLN=IBLN+2
.. ;
.. ;print employer name and address
.. S IBADD=^TMP("IBEMP",$J,"E",IBADDN,IBX) W !,$E($P(IBADD,"^",1),1,29),?32,$P(IBADD,"^",8),?55 S IBLNG=55,IBLN=IBLN+2
.. F IBI=2:1:7 S IBP=$P(IBADD,"^",IBI) I IBP'="" S IBP=IBP_$S(IBI<6:",",IBI=6:" ",1:"") D
... F S IBE=$P(IBP," ",1)_" ",IBP=$P(IBP," ",2,999) D W ?IBLNG,IBE S IBLNG=IBLNG+IBT Q:IBP=""
.... S IBT=$L(IBE) I (IBT+IBLNG)>IOM S IBLNG=55,IBLN=IBLN+1 W !
.. ;
.. ;print patient data
.. S IBPTNM="" F S IBPTNM=$O(^TMP("IBEMP",$J,"E",IBADDN,IBX,IBPTNM)) Q:IBPTNM="" D Q:IBQ
... S IBDFN="" F S IBDFN=$O(^TMP("IBEMP",$J,"E",IBADDN,IBX,IBPTNM,IBDFN)) Q:IBDFN="" I $D(^TMP("IBEMP",$J,IBDFN)) D:(IBLN+3)>IOSL HDR Q:IBQ D
.... S IBPAT=^TMP("IBEMP",$J,IBDFN),IBLN=IBLN+2 S Y=$P(IBPAT,"^",3) X ^DD("DD")
.... W !!,?3,"Patient: ",?12,$P(IBPAT,"^",1),?55,$P(IBPAT,"^",2),?70,$P(IBPAT,"^",5),?77,Y,?92,$E($P(IBPAT,"^",4),1,11),?107,"Home: ",$P($G(^DPT(IBDFN,.13)),"^",1)
.... ;
.... ;print employed's data
.... S IBZ="" F S IBZ=$O(^TMP("IBEMP",$J,"E",IBADDN,IBX,IBPTNM,IBDFN,IBZ)) Q:IBZ="" D:(IBLN'<IOSL) HDR Q:IBQ D
..... S IBEMPED=^TMP("IBEMP",$J,IBDFN,IBZ),IBLN=IBLN+1
..... W !,?3,"Employed: ",?13,$S(IBZ="P":"Patient: ",1:"Spouse: "),?22,$P(IBEMPED,"^",1),?55,$P(IBEMPED,"^",4),?70,$E($P(IBEMPED,"^",2),1,19),?92,$E($P(IBEMPED,"^",3),1,11)
..... I IBZ="P" W ?107,"Work: ",$P($G(^DPT(IBDFN,.13)),"^",2) ; we only have patients work number
I 'IBQ D PAUSE
K IBT,IBE,IBP,IBI,IBY,IBX,IBZ,IBQ,IBW,IBCNT,IBADD,IBADDN,IBLNG,IBDFN,IBPAT,IBPTNM,IBEMPED,X,Y
Q
;
HDR ;print the report header, allow user stops, for terminals only form feed on first page
S IBQ=$$STOP Q:IBQ D:IBPGN>0 PAUSE Q:IBQ I IBPGN>0!($E(IOST,1,2)["C-") W @IOF
S IBPGN=IBPGN+1,IBLN=5 W IBHDR,IBBEGE," - ",IBENDE I IOM<85 W !
W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN W:IBHDR'="" !,IBHDR1 W !,IBDSH,!
Q
;
PAUSE ;pause at end of screen if being displayed on a terminal
Q:$E(IOST,1,2)'["C-"
S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DIRUT)) S IBQ=1
Q
;
STOP() ;determine if user requested task to be stopped
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !!,"TASK STOPPED BY USER",!!
Q +$G(ZTSTOP)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOEMP2 3213 printed Sep 23, 2025@20:01:49 Page 2
IBOEMP2 ;ALB/ARH - EMPLOYER REPORT (PRINT) ; 6/19/93
+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 ;Array: patient: DFN)=pt name ^ SSN ^ event date ^ appt type ^ prim elig
+5 ; employed: DFN,x)=name ^ occupation ^ employment status ^ SSN
+6 ; employer: "E",EMPLOYER NAME)=count of employees per employer name
+7 ; "E",EMPLOYER NAME,y)=employer address
+8 ; "E",EMPLOYER NAME,y,PATIENT NAME,DFN,x)=""
+9 ;
+10 ; w/x = "P" if employed is patient, "S" for spouse otherwise
+11 ; y = number of employers with same name but not the same address, ie. 1:1:...
+12 ;
+13 ;
+14 DO HDR
+15 ;
P1 ;print report
+1 if '$DATA(^TMP("IBEMP",$JOB))
QUIT
SET IBW=IOM
+2 SET IBADDN=""
FOR
SET IBADDN=$ORDER(^TMP("IBEMP",$JOB,"E",IBADDN))
if IBADDN=""!(IBQ)
QUIT
SET IBCNT=^TMP("IBEMP",$JOB,"E",IBADDN)
SET IBX=""
Begin DoDot:1
+3 FOR
SET IBX=$ORDER(^TMP("IBEMP",$JOB,"E",IBADDN,IBX))
if IBX=""!(IBQ)
QUIT
if (IBLN+9)>IOSL
DO HDR
if IBQ
QUIT
Begin DoDot:2
+4 ;
+5 ;print employer name and address
+6 SET IBADD=^TMP("IBEMP",$JOB,"E",IBADDN,IBX)
WRITE !,$EXTRACT($PIECE(IBADD,"^",1),1,29),?32,$PIECE(IBADD,"^",8),?55
SET IBLNG=55
SET IBLN=IBLN+2
+7 FOR IBI=2:1:7
SET IBP=$PIECE(IBADD,"^",IBI)
IF IBP'=""
SET IBP=IBP_$SELECT(IBI<6:",",IBI=6:" ",1:"")
Begin DoDot:3
+8 FOR
SET IBE=$PIECE(IBP," ",1)_" "
SET IBP=$PIECE(IBP," ",2,999)
Begin DoDot:4
+9 SET IBT=$LENGTH(IBE)
IF (IBT+IBLNG)>IOM
SET IBLNG=55
SET IBLN=IBLN+1
WRITE !
End DoDot:4
WRITE ?IBLNG,IBE
SET IBLNG=IBLNG+IBT
if IBP=""
QUIT
End DoDot:3
+10 ;
+11 ;print patient data
+12 SET IBPTNM=""
FOR
SET IBPTNM=$ORDER(^TMP("IBEMP",$JOB,"E",IBADDN,IBX,IBPTNM))
if IBPTNM=""
QUIT
Begin DoDot:3
+13 SET IBDFN=""
FOR
SET IBDFN=$ORDER(^TMP("IBEMP",$JOB,"E",IBADDN,IBX,IBPTNM,IBDFN))
if IBDFN=""
QUIT
IF $DATA(^TMP("IBEMP",$JOB,IBDFN))
if (IBLN+3)>IOSL
DO HDR
if IBQ
QUIT
Begin DoDot:4
+14 SET IBPAT=^TMP("IBEMP",$JOB,IBDFN)
SET IBLN=IBLN+2
SET Y=$PIECE(IBPAT,"^",3)
XECUTE ^DD("DD")
+15 WRITE !!,?3,"Patient: ",?12,$PIECE(IBPAT,"^",1),?55,$PIECE(IBPAT,"^",2),?70,$PIECE(IBPAT,"^",5),?77,Y,?92,$EXTRACT($PIECE(IBPAT,"^",4),1,11),?107,"Home: ",$PIECE($GET(^DPT(IBDFN,.13)),"^",1)
+16 ;
+17 ;print employed's data
+18 SET IBZ=""
FOR
SET IBZ=$ORDER(^TMP("IBEMP",$JOB,"E",IBADDN,IBX,IBPTNM,IBDFN,IBZ))
if IBZ=""
QUIT
if (IBLN'<IOSL)
DO HDR
if IBQ
QUIT
Begin DoDot:5
+19 SET IBEMPED=^TMP("IBEMP",$JOB,IBDFN,IBZ)
SET IBLN=IBLN+1
+20 WRITE !,?3,"Employed: ",?13,$SELECT(IBZ="P":"Patient: ",1:"Spouse: "),?22,$PIECE(IBEMPED,"^",1),?55,$PIECE(IBEMPED,"^",4),?70,$EXTRACT($PIECE(IBEMPED,"^",2),1,19),?92,$EXTRACT($PIECE(IBEMPED,"^",3),1
,11)
+21 ; we only have patients work number
IF IBZ="P"
WRITE ?107,"Work: ",$PIECE($GET(^DPT(IBDFN,.13)),"^",2)
End DoDot:5
End DoDot:4
End DoDot:3
if IBQ
QUIT
End DoDot:2
WRITE !!,IBDSH,!
SET IBLN=IBLN+2
End DoDot:1
if IBQ
QUIT
+22 IF 'IBQ
DO PAUSE
+23 KILL IBT,IBE,IBP,IBI,IBY,IBX,IBZ,IBQ,IBW,IBCNT,IBADD,IBADDN,IBLNG,IBDFN,IBPAT,IBPTNM,IBEMPED,X,Y
+24 QUIT
+25 ;
HDR ;print the report header, allow user stops, for terminals only form feed on first page
+1 SET IBQ=$$STOP
if IBQ
QUIT
if IBPGN>0
DO PAUSE
if IBQ
QUIT
IF IBPGN>0!($EXTRACT(IOST,1,2)["C-")
WRITE @IOF
+2 SET IBPGN=IBPGN+1
SET IBLN=5
WRITE IBHDR,IBBEGE," - ",IBENDE
IF IOM<85
WRITE !
+3 WRITE ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN
if IBHDR'=""
WRITE !,IBHDR1
WRITE !,IBDSH,!
+4 QUIT
+5 ;
PAUSE ;pause at end of screen if being displayed on a terminal
+1 if $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DIRUT))
SET IBQ=1
+3 QUIT
+4 ;
STOP() ;determine if user requested task to be stopped
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
IF +$GET(IBPGN)
WRITE !!,"TASK STOPPED BY USER",!!
+2 QUIT +$GET(ZTSTOP)
