IBCNBCD4 ;ALB/AWC - MCCF FY14 Subscriber Display Screens ;25 Feb 2015
;;2.0;INTEGRATED BILLING;**528**;21-MAR-94;Build 163
;;Per VA Directive 6402, this routine should not be modified.
;
;Input Parameters:
; See routine IBCNBCD1
;
SBDISP(IBBUFDA,IBDFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,IBFNAM,IBVAL,IBHOLD,IBXHOLD) ; Display Subscriber Registration Data - Called from ACSUB^IBCNBAA
N IBI,IBCNT,IBOUT,IBREL,IBIEN,IBV,DIERR,IBRET
S IBCNT=1,(IBOUT,IBREL,IBIEN)=0
;
S IBHOLD=$NA(^TMP("IBCNBCD4 SBDISP HOLD DATA",$J)),IBXHOLD=$NA(^TMP("IBCNBCD4 SBDISP HOLD EXTERNAL DATA",$J))
K @IBHOLD
K @IBXHOLD
;
N IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20
S IB1="Subscriber Id:"
S IB2="Whose Insurance:"
S IB3="Relationship:"
S IB4="Rx Relationship:"
S IB5="Rx Person Code:"
S IB6="Subscriber Name:"
S IB7="Subscriber's DOB:"
S IB8="Subscriber's SSN:"
S IB9="Subscriber's SEX:"
S IB10="Primary Provider:"
S IB11="Provider Phone:"
S IB12="Coor of Benefits:"
S IB13="Patient Id:"
S IB14="Subscr Str Ln 1:"
S IB15="Subscr Str Ln 2:"
S IB16="Subscr City:"
S IB17="Subscr State:"
S IB18="Subscr Zip:"
S IB19="Subscr Country:"
S IB20="Subscr Phone:"
;
;
; -- get corresponding IEN from the PT. RELATIONSHIP - HIPAA(#2.312,4.03) to the IEN for the RELATIONSHIP FILE(#408.11)
S IBV=$P($G(IBVAL),U,2) I IBV]"" S IBREL=+$O(^DG(408.11,"B",IBV,0))
;
; -- get the pointer to where the demographic data is located via the PATIENT RELATION FILE(#408.12)
I IBV]"",+IBREL F IBI=0:0 S IBI=$O(^DGPR(408.12,"B",IBDFN,IBI)) Q:IBI'>0!(IBOUT) D Q:$D(DIERR)
. ;
. D GETS^DIQ(408.12,IBI_",",".01;.02;.03","I","IBRET","DIERR") I $D(DIERR) W !,"Error...SBVAL-IBCNBCD4 Cannot access Patient Relationship data!" D PAUSE^VALM1 Q
. ;
. I +$G(IBRET(408.12,IBI_",",.02,"I"))=IBREL D
. . ;
. . S IBIEN=$P($G(IBRET(408.12,IBI_",",.03,"I")),";"),IBFNAM=$P($P($G(IBRET(408.12,IBI_",",.03,"I")),"("),";",2)
. . S IBOUT=1
;
; -- write header
W !,! D WRTFLD(" Subscriber Data: Patient Registration Patient Insurance Policy ",0,80,"BU")
;
; -- if relationship demographic data located in patient file(#2)
I +IBPOLDA,+IBIEN,IBFNAM="DPT" D Q
. ;
. D PDIS^IBCNBCD5(IBBUFDA,IBIEN,IBSIEN,IBSEL,IBV,IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20,.IBHOLD,.IBXHOLD)
. ;
. D WRTBLD
;
;
; -- if relationship demographic data located in income person file(#408.13)
I +IBPOLDA,+IBIEN,IBFNAM="DGPR" D Q
. ;
. D IDIS^IBCNBCD5(IBBUFDA,IBIEN,IBSIEN,IBSEL,IBV,IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20,.IBHOLD,.IBXHOLD)
. ;
. D WRTBLD
;
;
; -- no relationship patient/income person data found
I +IBPOLDA,'IBIEN D Q
. ;
. D NDIS^IBCNBCD5(IBBUFDA,IBIEN,IBSIEN,IBSEL,IBV,IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20,.IBHOLD,.IBXHOLD)
. ;
. D WRTBLD
Q
;
BD(IBBUFDA,IBTXT,IBFLD,IBDAT,IBSEL,IBSIEN,IBXFLD,IBXDAT,IBCNT,IBHOLD,IBXHOLD) ; Display Insurance Verification Processor information <and> Insurance Policy information
N X,Y,IBOVER,IBMERG,IBITER,IBITER1,IBITER2,IBDIS,IBEM,%DT
S (IBITER1,IBITER2)=0,IBITER=1
;
; ******* left side of screen BEGIN *****
S @IBHOLD@(2,IBFLD)=IBDAT
;
; -- format date of birth
I IBFLD=".03" D
. S X=IBDAT K Y S %DT="XP",%DT(0)=-DT D ^%DT K %DT(0) S X=Y K:Y<1 X
. I $G(X)]"" S IBDAT=$$UP^XLFSTR($$FMTE^XLFDT(X,1)),@IBHOLD@(2,IBFLD)=IBDAT
; -- format ssn
I IBFLD=".09" D
. I $L(IBDAT)=9 S IBDAT=$E(IBDAT,1,3)_"-"_$E(IBDAT,4,5)_"-"_$E(IBDAT,6,9),@IBHOLD@(2,IBFLD)=IBDAT Q
. I $L(IBDAT)=11 S IBDAT=$E(IBDAT,10,11)_$E(IBDAT,1,9),@IBHOLD@(2,IBFLD)=IBDAT
; -- format phone number
I IBFLD=".131" D
. I $L(IBDAT)=7 S IBDAT=$E(IBDAT,1,3)_"-"_$E(IBDAT,4,7),@IBHOLD@(2,IBFLD)=IBDAT Q
. I $L(IBDAT)=10 S IBDAT="("_$E(IBDAT,1,3)_")"_$E(IBDAT,4,6)_"-"_$E(IBDAT,7,10),@IBHOLD@(2,IBFLD)=IBDAT Q
. I $L(IBDAT)=11 S IBDAT=$E(IBDAT)_"-"_"("_$E(IBDAT,1,3)_")"_$E(IBDAT,4,6)_"-"_$E(IBDAT,7,10),@IBHOLD@(2,IBFLD)=IBDAT Q
. I $L(IBDAT)=12,IBDAT?3N."-".3N."-".4N S IBDAT="("_$E(IBDAT,1,3)_")"_$E(IBDAT,4,12),@IBHOLD@(2,IBFLD)=IBDAT
;
; -- self whose insurance and relationship
I IBSEL=18&(IBFLD="60.05") S IBDAT="VETERAN",@IBHOLD@(2,IBFLD)=IBDAT
I IBSEL=18&(IBFLD="60.14") S IBDAT="SELF",@IBHOLD@(2,IBFLD)=IBDAT
;
; -- spouse whose insurance and relationship
I IBSEL=1&(IBFLD="60.05") S IBDAT="SPOUSE",@IBHOLD@(2,IBFLD)=IBDAT
I IBSEL=1&(IBFLD="60.14") S IBDAT="SPOUSE",@IBHOLD@(2,IBFLD)=IBDAT
;
; -- not spouse or self
I IBSEL'=18&(IBSEL'=1)&(IBFLD="60.14") S IBDAT="",@IBHOLD@(2,IBFLD)=IBDAT
;
; -- rx relationship
I IBFLD="60.15",IBDAT]"" D Q:$D(DIERR)
. S IBDIS=$S(IBDAT=0:1,IBDAT=1:2,IBDAT=2:3,IBDAT=3:4,IBDAT=4:5,1:IBDAT)
. I +IBDIS D
. . S IBDAT=IBDAT_" - "_$$GET1^DIQ(9002313.19,IBDIS_",",".02","E",,"DIERR") I $D(DIERR) D IBQ("Error #2...DISBUF-IBCNBCD4 Cannot access Rx Relationship data!") Q
S IBITER1=$L(IBDAT)-1\29+1
; ******* left side of screen END *****
;
;
; ******* right side of screen BEGIN *****
; -- rx relationship
I IBXFLD="4.05",IBXDAT]"" D Q:$D(DIERR)
. S IBDIS=$S(IBXDAT=0:1,IBXDAT=1:2,IBXDAT=2:3,IBXDAT=3:4,IBXDAT=4:5,1:IBXDAT)
. I +IBDIS D
. . S IBXDAT=IBXDAT_" - "_$$GET1^DIQ(9002313.19,IBDIS_",",".02","E",,"DIERR") I $D(DIERR) D IBQ("Error #4...DISBUF-IBCNBCD4 Cannot access Rx Relationship data!") Q
; ******* right side of screen END *****
;
S @IBXHOLD@(2,IBXFLD)=IBXDAT
S IBITER2=$L(IBXDAT)-1\29+1
S IBITER=$S(IBITER2>IBITER1:IBITER2,IBITER1>IBITER2:IBITER1,IBITER1=IBITER2:IBITER1,1:1)
S IBOVER=$S(IBDAT'=""&(IBDAT'=IBXDAT):"B",1:""),IBMERG=$S(IBXDAT="":"B",1:"")
D WRTLN(IBTXT,IBDAT,IBXDAT,IBOVER,IBMERG)
Q
;
WRTLN(IBTXT,FLD1,FLD2,OVER,MERG,ATTR) ; write a line of formatted data with label and two fields
N IBCTR,IBSV,IBEV,IBBUFV,IBSPV
S IBSV=1,IBEV=29
S ATTR=$G(ATTR),OVER=ATTR_$G(OVER),MERG=ATTR_$G(MERG)
S IBTXT=$J(IBTXT,17)_" "
W !
I '$G(IBITER) S IBITER=1
F IBCTR=1:1:IBITER D
. S IBBUFV=$E(FLD1,IBSV,IBEV)
. S IBSPV=$E(FLD2,IBSV,IBEV)
. I $L(IBBUFV)<29 S IBBUFV=IBBUFV_$J("",29-$L(IBBUFV))
. I $L(IBSPV)<29 S IBSPV=IBSPV_$J("",29-$L(IBSPV))
. D:IBCTR=1 WRTFLD(IBTXT,0,19,ATTR)
. D WRTFLD(IBBUFV,19,29,MERG)
. D WRTFLD(" | ",48,3,ATTR),WRTFLD(IBSPV,51,29,OVER)
. I IBITER>1,IBCTR'=IBITER W !
. S IBSV=IBSV+29
. S IBEV=IBEV+29
Q
;
WRTFLD(STRING,COL,WD,ATTR) ; write an individual field with display attributes
N ATTRB,ATTRE,DX,DY,X,Y
S ATTRB="",ATTRB=$S(ATTR["B":$G(IOINHI),1:"")_$S(ATTR["U":$G(IOUON),1:"")
S ATTRE="",ATTRE=$S(ATTR["B":$G(IOINORM),1:"")_$S(ATTR["U":$G(IOUOFF),1:"")
;
S DX=COL,DY=$Y X IOXY
W ATTRB,$E(STRING,1,WD),ATTRE
S DX=(COL+WD),DY=$Y X IOXY
Q
;
WRTBLD ; Write footer in bold
N IBF1,IBF2
S IBF1="(bold=accepted on merge)",IBF2="(bold=replaced on overwrite)"
D WRTLN("",IBF1,IBF2,"","","U")
Q
;
IBQ(IBEM) ; write error message
; Input: IBEM - Error message text
W !,IBEM
D PAUSE^VALM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBCD4 7132 printed Apr 09, 2024@21:12:52 Page 2
IBCNBCD4 ;ALB/AWC - MCCF FY14 Subscriber Display Screens ;25 Feb 2015
+1 ;;2.0;INTEGRATED BILLING;**528**;21-MAR-94;Build 163
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Input Parameters:
+5 ; See routine IBCNBCD1
+6 ;
SBDISP(IBBUFDA,IBDFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,IBFNAM,IBVAL,IBHOLD,IBXHOLD) ; Display Subscriber Registration Data - Called from ACSUB^IBCNBAA
+1 NEW IBI,IBCNT,IBOUT,IBREL,IBIEN,IBV,DIERR,IBRET
+2 SET IBCNT=1
SET (IBOUT,IBREL,IBIEN)=0
+3 ;
+4 SET IBHOLD=$NAME(^TMP("IBCNBCD4 SBDISP HOLD DATA",$JOB))
SET IBXHOLD=$NAME(^TMP("IBCNBCD4 SBDISP HOLD EXTERNAL DATA",$JOB))
+5 KILL @IBHOLD
+6 KILL @IBXHOLD
+7 ;
+8 NEW IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20
+9 SET IB1="Subscriber Id:"
+10 SET IB2="Whose Insurance:"
+11 SET IB3="Relationship:"
+12 SET IB4="Rx Relationship:"
+13 SET IB5="Rx Person Code:"
+14 SET IB6="Subscriber Name:"
+15 SET IB7="Subscriber's DOB:"
+16 SET IB8="Subscriber's SSN:"
+17 SET IB9="Subscriber's SEX:"
+18 SET IB10="Primary Provider:"
+19 SET IB11="Provider Phone:"
+20 SET IB12="Coor of Benefits:"
+21 SET IB13="Patient Id:"
+22 SET IB14="Subscr Str Ln 1:"
+23 SET IB15="Subscr Str Ln 2:"
+24 SET IB16="Subscr City:"
+25 SET IB17="Subscr State:"
+26 SET IB18="Subscr Zip:"
+27 SET IB19="Subscr Country:"
+28 SET IB20="Subscr Phone:"
+29 ;
+30 ;
+31 ; -- get corresponding IEN from the PT. RELATIONSHIP - HIPAA(#2.312,4.03) to the IEN for the RELATIONSHIP FILE(#408.11)
+32 SET IBV=$PIECE($GET(IBVAL),U,2)
IF IBV]""
SET IBREL=+$ORDER(^DG(408.11,"B",IBV,0))
+33 ;
+34 ; -- get the pointer to where the demographic data is located via the PATIENT RELATION FILE(#408.12)
+35 IF IBV]""
IF +IBREL
FOR IBI=0:0
SET IBI=$ORDER(^DGPR(408.12,"B",IBDFN,IBI))
if IBI'>0!(IBOUT)
QUIT
Begin DoDot:1
+36 ;
+37 DO GETS^DIQ(408.12,IBI_",",".01;.02;.03","I","IBRET","DIERR")
IF $DATA(DIERR)
WRITE !,"Error...SBVAL-IBCNBCD4 Cannot access Patient Relationship data!"
DO PAUSE^VALM1
QUIT
+38 ;
+39 IF +$GET(IBRET(408.12,IBI_",",.02,"I"))=IBREL
Begin DoDot:2
+40 ;
+41 SET IBIEN=$PIECE($GET(IBRET(408.12,IBI_",",.03,"I")),";")
SET IBFNAM=$PIECE($PIECE($GET(IBRET(408.12,IBI_",",.03,"I")),"("),";",2)
+42 SET IBOUT=1
End DoDot:2
End DoDot:1
if $DATA(DIERR)
QUIT
+43 ;
+44 ; -- write header
+45 WRITE !,!
DO WRTFLD(" Subscriber Data: Patient Registration Patient Insurance Policy ",0,80,"BU")
+46 ;
+47 ; -- if relationship demographic data located in patient file(#2)
+48 IF +IBPOLDA
IF +IBIEN
IF IBFNAM="DPT"
Begin DoDot:1
+49 ;
+50 DO PDIS^IBCNBCD5(IBBUFDA,IBIEN,IBSIEN,IBSEL,IBV,IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20,.IBHOLD,.IBXHOLD)
+51 ;
+52 DO WRTBLD
End DoDot:1
QUIT
+53 ;
+54 ;
+55 ; -- if relationship demographic data located in income person file(#408.13)
+56 IF +IBPOLDA
IF +IBIEN
IF IBFNAM="DGPR"
Begin DoDot:1
+57 ;
+58 DO IDIS^IBCNBCD5(IBBUFDA,IBIEN,IBSIEN,IBSEL,IBV,IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20,.IBHOLD,.IBXHOLD)
+59 ;
+60 DO WRTBLD
End DoDot:1
QUIT
+61 ;
+62 ;
+63 ; -- no relationship patient/income person data found
+64 IF +IBPOLDA
IF 'IBIEN
Begin DoDot:1
+65 ;
+66 DO NDIS^IBCNBCD5(IBBUFDA,IBIEN,IBSIEN,IBSEL,IBV,IB1,IB2,IB3,IB4,IB5,IB6,IB7,IB8,IB9,IB10,IB11,IB12,IB13,IB14,IB15,IB16,IB17,IB18,IB19,IB20,.IBHOLD,.IBXHOLD)
+67 ;
+68 DO WRTBLD
End DoDot:1
QUIT
+69 QUIT
+70 ;
BD(IBBUFDA,IBTXT,IBFLD,IBDAT,IBSEL,IBSIEN,IBXFLD,IBXDAT,IBCNT,IBHOLD,IBXHOLD) ; Display Insurance Verification Processor information <and> Insurance Policy information
+1 NEW X,Y,IBOVER,IBMERG,IBITER,IBITER1,IBITER2,IBDIS,IBEM,%DT
+2 SET (IBITER1,IBITER2)=0
SET IBITER=1
+3 ;
+4 ; ******* left side of screen BEGIN *****
+5 SET @IBHOLD@(2,IBFLD)=IBDAT
+6 ;
+7 ; -- format date of birth
+8 IF IBFLD=".03"
Begin DoDot:1
+9 SET X=IBDAT
KILL Y
SET %DT="XP"
SET %DT(0)=-DT
DO ^%DT
KILL %DT(0)
SET X=Y
if Y<1
KILL X
+10 IF $GET(X)]""
SET IBDAT=$$UP^XLFSTR($$FMTE^XLFDT(X,1))
SET @IBHOLD@(2,IBFLD)=IBDAT
End DoDot:1
+11 ; -- format ssn
+12 IF IBFLD=".09"
Begin DoDot:1
+13 IF $LENGTH(IBDAT)=9
SET IBDAT=$EXTRACT(IBDAT,1,3)_"-"_$EXTRACT(IBDAT,4,5)_"-"_$EXTRACT(IBDAT,6,9)
SET @IBHOLD@(2,IBFLD)=IBDAT
QUIT
+14 IF $LENGTH(IBDAT)=11
SET IBDAT=$EXTRACT(IBDAT,10,11)_$EXTRACT(IBDAT,1,9)
SET @IBHOLD@(2,IBFLD)=IBDAT
End DoDot:1
+15 ; -- format phone number
+16 IF IBFLD=".131"
Begin DoDot:1
+17 IF $LENGTH(IBDAT)=7
SET IBDAT=$EXTRACT(IBDAT,1,3)_"-"_$EXTRACT(IBDAT,4,7)
SET @IBHOLD@(2,IBFLD)=IBDAT
QUIT
+18 IF $LENGTH(IBDAT)=10
SET IBDAT="("_$EXTRACT(IBDAT,1,3)_")"_$EXTRACT(IBDAT,4,6)_"-"_$EXTRACT(IBDAT,7,10)
SET @IBHOLD@(2,IBFLD)=IBDAT
QUIT
+19 IF $LENGTH(IBDAT)=11
SET IBDAT=$EXTRACT(IBDAT)_"-"_"("_$EXTRACT(IBDAT,1,3)_")"_$EXTRACT(IBDAT,4,6)_"-"_$EXTRACT(IBDAT,7,10)
SET @IBHOLD@(2,IBFLD)=IBDAT
QUIT
+20 IF $LENGTH(IBDAT)=12
IF IBDAT?3N."-".3N."-".4N
SET IBDAT="("_$EXTRACT(IBDAT,1,3)_")"_$EXTRACT(IBDAT,4,12)
SET @IBHOLD@(2,IBFLD)=IBDAT
End DoDot:1
+21 ;
+22 ; -- self whose insurance and relationship
+23 IF IBSEL=18&(IBFLD="60.05")
SET IBDAT="VETERAN"
SET @IBHOLD@(2,IBFLD)=IBDAT
+24 IF IBSEL=18&(IBFLD="60.14")
SET IBDAT="SELF"
SET @IBHOLD@(2,IBFLD)=IBDAT
+25 ;
+26 ; -- spouse whose insurance and relationship
+27 IF IBSEL=1&(IBFLD="60.05")
SET IBDAT="SPOUSE"
SET @IBHOLD@(2,IBFLD)=IBDAT
+28 IF IBSEL=1&(IBFLD="60.14")
SET IBDAT="SPOUSE"
SET @IBHOLD@(2,IBFLD)=IBDAT
+29 ;
+30 ; -- not spouse or self
+31 IF IBSEL'=18&(IBSEL'=1)&(IBFLD="60.14")
SET IBDAT=""
SET @IBHOLD@(2,IBFLD)=IBDAT
+32 ;
+33 ; -- rx relationship
+34 IF IBFLD="60.15"
IF IBDAT]""
Begin DoDot:1
+35 SET IBDIS=$SELECT(IBDAT=0:1,IBDAT=1:2,IBDAT=2:3,IBDAT=3:4,IBDAT=4:5,1:IBDAT)
+36 IF +IBDIS
Begin DoDot:2
+37 SET IBDAT=IBDAT_" - "_$$GET1^DIQ(9002313.19,IBDIS_",",".02","E",,"DIERR")
IF $DATA(DIERR)
DO IBQ("Error #2...DISBUF-IBCNBCD4 Cannot access Rx Relationship data!")
QUIT
End DoDot:2
End DoDot:1
if $DATA(DIERR)
QUIT
+38 SET IBITER1=$LENGTH(IBDAT)-1\29+1
+39 ; ******* left side of screen END *****
+40 ;
+41 ;
+42 ; ******* right side of screen BEGIN *****
+43 ; -- rx relationship
+44 IF IBXFLD="4.05"
IF IBXDAT]""
Begin DoDot:1
+45 SET IBDIS=$SELECT(IBXDAT=0:1,IBXDAT=1:2,IBXDAT=2:3,IBXDAT=3:4,IBXDAT=4:5,1:IBXDAT)
+46 IF +IBDIS
Begin DoDot:2
+47 SET IBXDAT=IBXDAT_" - "_$$GET1^DIQ(9002313.19,IBDIS_",",".02","E",,"DIERR")
IF $DATA(DIERR)
DO IBQ("Error #4...DISBUF-IBCNBCD4 Cannot access Rx Relationship data!")
QUIT
End DoDot:2
End DoDot:1
if $DATA(DIERR)
QUIT
+48 ; ******* right side of screen END *****
+49 ;
+50 SET @IBXHOLD@(2,IBXFLD)=IBXDAT
+51 SET IBITER2=$LENGTH(IBXDAT)-1\29+1
+52 SET IBITER=$SELECT(IBITER2>IBITER1:IBITER2,IBITER1>IBITER2:IBITER1,IBITER1=IBITER2:IBITER1,1:1)
+53 SET IBOVER=$SELECT(IBDAT'=""&(IBDAT'=IBXDAT):"B",1:"")
SET IBMERG=$SELECT(IBXDAT="":"B",1:"")
+54 DO WRTLN(IBTXT,IBDAT,IBXDAT,IBOVER,IBMERG)
+55 QUIT
+56 ;
WRTLN(IBTXT,FLD1,FLD2,OVER,MERG,ATTR) ; write a line of formatted data with label and two fields
+1 NEW IBCTR,IBSV,IBEV,IBBUFV,IBSPV
+2 SET IBSV=1
SET IBEV=29
+3 SET ATTR=$GET(ATTR)
SET OVER=ATTR_$GET(OVER)
SET MERG=ATTR_$GET(MERG)
+4 SET IBTXT=$JUSTIFY(IBTXT,17)_" "
+5 WRITE !
+6 IF '$GET(IBITER)
SET IBITER=1
+7 FOR IBCTR=1:1:IBITER
Begin DoDot:1
+8 SET IBBUFV=$EXTRACT(FLD1,IBSV,IBEV)
+9 SET IBSPV=$EXTRACT(FLD2,IBSV,IBEV)
+10 IF $LENGTH(IBBUFV)<29
SET IBBUFV=IBBUFV_$JUSTIFY("",29-$LENGTH(IBBUFV))
+11 IF $LENGTH(IBSPV)<29
SET IBSPV=IBSPV_$JUSTIFY("",29-$LENGTH(IBSPV))
+12 if IBCTR=1
DO WRTFLD(IBTXT,0,19,ATTR)
+13 DO WRTFLD(IBBUFV,19,29,MERG)
+14 DO WRTFLD(" | ",48,3,ATTR)
DO WRTFLD(IBSPV,51,29,OVER)
+15 IF IBITER>1
IF IBCTR'=IBITER
WRITE !
+16 SET IBSV=IBSV+29
+17 SET IBEV=IBEV+29
End DoDot:1
+18 QUIT
+19 ;
WRTFLD(STRING,COL,WD,ATTR) ; write an individual field with display attributes
+1 NEW ATTRB,ATTRE,DX,DY,X,Y
+2 SET ATTRB=""
SET ATTRB=$SELECT(ATTR["B":$GET(IOINHI),1:"")_$SELECT(ATTR["U":$GET(IOUON),1:"")
+3 SET ATTRE=""
SET ATTRE=$SELECT(ATTR["B":$GET(IOINORM),1:"")_$SELECT(ATTR["U":$GET(IOUOFF),1:"")
+4 ;
+5 SET DX=COL
SET DY=$Y
XECUTE IOXY
+6 WRITE ATTRB,$EXTRACT(STRING,1,WD),ATTRE
+7 SET DX=(COL+WD)
SET DY=$Y
XECUTE IOXY
+8 QUIT
+9 ;
WRTBLD ; Write footer in bold
+1 NEW IBF1,IBF2
+2 SET IBF1="(bold=accepted on merge)"
SET IBF2="(bold=replaced on overwrite)"
+3 DO WRTLN("",IBF1,IBF2,"","","U")
+4 QUIT
+5 ;
IBQ(IBEM) ; write error message
+1 ; Input: IBEM - Error message text
+2 WRITE !,IBEM
+3 DO PAUSE^VALM1
+4 QUIT
