IBCSCU ;ALB/MJB - MCCR SCREEN UTILITY ROUTINE ;27 MAY 88 11:09
;;2.0;INTEGRATED BILLING;**52,51,348,432,447,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRSCU
;
S IBW=1,IBU="UNSPECIFIED",IBUN=IBU_" [NOT REQUIRED]",IBV=$S($D(IBV):IBV,1:1) D HOME^%ZIS
;S IBWW1="X ""F Z2=1:1:(Z1-$L(Z)) S Z=Z_"""" """""" W Z Q"
S (IBVO,IBVI)="" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M
;
I $D(IOST(0)) S X="IOINHI;IOINLOW;IOINORM" D ENDR^%ZISS
I $L(IOINHI),$L(IOINLOW) S IBVI=IOINHI,IBVO=$S(IOINORM]"":IOINORM,1:IBINLOW)
D KILL^%ZISS
;I $D(^%ZIS(2,IOST(0),7)) S I=^(7) I $L($P(I,"^",1)),$L($P(I,"^",2)) S IBVI=$P(I,"^",1),IBVO=$S($P(I,"^",3)]"":$P(I,"^",3),1:$P(I,"^",2))
;
M ;I $L(IBVI_IBVO)>4 S X=80 X ^%ZOSF("RM")
S IBWW="W:IBW ! S Z=$S(IBV:""<""_Z_"">"",$E(IBV1,Z):""<""_Z_"">"",1:""[""_Z_""]"") W:$E(Z)=""["" IBVI,Z,IBVO W:$E(Z)'=""["" Z Q"
;S IBWW="W:IBW ! S Z=$S(IOST=""C-QUME""&($L(IBVI)'=2):Z,IBV:""<""_Z_"">"",$E(IBV1,Z):""<""_Z_"">"",1:""[""_Z_""]"") W:$E(Z)=""["" @IBVI,Z,@IBVO W:$E(Z)'=""["" Z Q"
I $D(IBPAR) S IBV=0,IBVV="00000" Q
S IBBNO=$P(^DGCR(399,IBIFN,0),"^",1)
S IBVV=$S('$$INPAT^IBCEF(IBIFN):"00010100001",1:"00001010001"),X="63266556" ; IB*2.0*447 BI
;JWS;IB*2.0*592;skip screen 9 for Dental
I $$FT^IBCEF(IBIFN)=7 S IBVV="00010100101"
I $P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),U,19),2)),U,9)'="",$S($D(^DGCR(399,IBIFN,"I1")):1,1:$P($G(^DGCR(399,IBIFN,"M")),U,11)) S $E(IBVV,11)="0"
Q
;
H ;Screen Header
S L="",$P(L,"=",81)=""
I $D(IBH("HELP")) S X="HELP SCREEN" W @IOF,!?(40-($L(X)\2)),IBVI,X,IBVO,!,L G HQ
; IB*2.0*447 BI Start
S X=$P("DEMOGRAPHIC^EMPLOYMENT^PAYER^EVENT - INPATIENT^EVENT - OUTPATIENT^BILLING - GENERAL^BILLING - GENERAL^BILLING - CLAIM^AMBULANCE^BILLING - SPECIFIC^LOCALLY DEFINED","^",IBSR)_" INFORMATION",X1="SCREEN <"_+IBSR_">"
;JWS;IB*2.0*592; Dental
I $$FT^IBCEF(IBIFN)=7,IBSR=8 S X="DENTAL - CLAIM INFORMATION"
; IB*2.0*447 BI End
N IB0,IBT S IB0=$G(^DGCR(399,IBIFN,0)),IBT=$P(IB0,U,19),DGINPT=$S($$INPAT^IBCEF(IBIFN):"Inpat",1:"Outpat")
;
W @IOF ; clear screen
W !,VADM(1) ; name
W " ",$P(VADM(2),"^",2) ; ssn
W " BILL#: ",IBBNO_" - "_DGINPT,"/" ; claim# - type
I IBT=2 W "1500" ; form type 2
I IBT=3 W $TR($P($G(^IBE(353,3,0)),U,1),"-") ; form type 3
;JWS;IB*2.0*592 US1108 - Dental form 7
;IA# 2056
I IBT=7 W $$GET1^DIQ(353,"7,",.01) ; form type 7 - dental
W ?(80-$L(X1)),X1 ; screen#
W !,L ; separator line
W !?(40-($L(X)\2)),IBVI,X,IBVO ; screen description
HQ ;
K L,DGINPT
Q
;
A ;Format Address(es)
N Y F I=IBA1:1:IBA1+2 I $P(IB(IBAD),U,I)]"" S IBA(IBA2)=$P(IB(IBAD),U,I),IBA2=IBA2+2
I IBA2=1 S IBA(1)="STREET ADDRESS UNKNOWN",IBA2=IBA2+2
S J=$S($D(^DIC(5,+$P(IB(IBAD),U,IBA1+4),0)):$P(^(0),U,2),1:""),J(1)=$P(IB(IBAD),U,IBA1+3),J(2)=$P(IB(IBAD),U,IBA1+11),IBA(IBA2)=$S(J(1)]""&(J]""):J(1)_", "_J,J(1)]"":J(1),J]"":J,1:"CITY/STATE UNKNOWN")
S Y=$S(IBAD=.11!(IBAD=.121):$P(IB(IBAD),U,IBA1+11),IBAD=.25:$P($G(^DPT(+$G(DFN),.22)),U,6),IBAD=.311:$P($G(^DPT(+$G(DFN),.22)),U,5),1:"") D ZIPOUT^VAFADDR
S IBA(IBA2)=IBA(IBA2)_" "_Y F I=0:0 S I=$O(IBA(I)) Q:I="" S IBA(I)=$E(IBA(I),1,25)
K IBA1,I,J Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSCU 3515 printed Apr 09, 2024@21:10 Page 2
IBCSCU ;ALB/MJB - MCCR SCREEN UTILITY ROUTINE ;27 MAY 88 11:09
+1 ;;2.0;INTEGRATED BILLING;**52,51,348,432,447,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSCU
+5 ;
+6 SET IBW=1
SET IBU="UNSPECIFIED"
SET IBUN=IBU_" [NOT REQUIRED]"
SET IBV=$SELECT($DATA(IBV):IBV,1:1)
DO HOME^%ZIS
+7 ;S IBWW1="X ""F Z2=1:1:(Z1-$L(Z)) S Z=Z_"""" """""" W Z Q"
+8 SET (IBVO,IBVI)=""
IF $SELECT('$DATA(IOST(0)):1,'$DATA(^DG(43,1,0)):1,'$PIECE(^DG(43,1,0),"^",36):1,$DATA(^DG(43,1,"TERM",IOST(0))):1,1:0)
GOTO M
+9 ;
+10 IF $DATA(IOST(0))
SET X="IOINHI;IOINLOW;IOINORM"
DO ENDR^%ZISS
+11 IF $LENGTH(IOINHI)
IF $LENGTH(IOINLOW)
SET IBVI=IOINHI
SET IBVO=$SELECT(IOINORM]"":IOINORM,1:IBINLOW)
+12 DO KILL^%ZISS
+13 ;I $D(^%ZIS(2,IOST(0),7)) S I=^(7) I $L($P(I,"^",1)),$L($P(I,"^",2)) S IBVI=$P(I,"^",1),IBVO=$S($P(I,"^",3)]"":$P(I,"^",3),1:$P(I,"^",2))
+14 ;
M ;I $L(IBVI_IBVO)>4 S X=80 X ^%ZOSF("RM")
+1 SET IBWW="W:IBW ! S Z=$S(IBV:""<""_Z_"">"",$E(IBV1,Z):""<""_Z_"">"",1:""[""_Z_""]"") W:$E(Z)=""["" IBVI,Z,IBVO W:$E(Z)'=""["" Z Q"
+2 ;S IBWW="W:IBW ! S Z=$S(IOST=""C-QUME""&($L(IBVI)'=2):Z,IBV:""<""_Z_"">"",$E(IBV1,Z):""<""_Z_"">"",1:""[""_Z_""]"") W:$E(Z)=""["" @IBVI,Z,@IBVO W:$E(Z)'=""["" Z Q"
+3 IF $DATA(IBPAR)
SET IBV=0
SET IBVV="00000"
QUIT
+4 SET IBBNO=$PIECE(^DGCR(399,IBIFN,0),"^",1)
+5 ; IB*2.0*447 BI
SET IBVV=$SELECT('$$INPAT^IBCEF(IBIFN):"00010100001",1:"00001010001")
SET X="63266556"
+6 ;JWS;IB*2.0*592;skip screen 9 for Dental
+7 IF $$FT^IBCEF(IBIFN)=7
SET IBVV="00010100101"
+8 IF $PIECE($GET(^IBE(353,+$PIECE($GET(^DGCR(399,IBIFN,0)),U,19),2)),U,9)'=""
IF $SELECT($DATA(^DGCR(399,IBIFN,"I1")):1,1:$PIECE($GET(^DGCR(399,IBIFN,"M")),U,11))
SET $EXTRACT(IBVV,11)="0"
+9 QUIT
+10 ;
H ;Screen Header
+1 SET L=""
SET $PIECE(L,"=",81)=""
+2 IF $DATA(IBH("HELP"))
SET X="HELP SCREEN"
WRITE @IOF,!?(40-($LENGTH(X)\2)),IBVI,X,IBVO,!,L
GOTO HQ
+3 ; IB*2.0*447 BI Start
+4 SET X=$PIECE("DEMOGRAPHIC^EMPLOYMENT^PAYER^EVENT - INPATIENT^EVENT - OUTPATIENT^BILLING - GENERAL^BILLING - GENERAL^BILLING - CLAIM^AMBULANCE^BILLING - SPECIFIC^LOCALLY DEFINED","^",IBSR)_" INFORMATION"
SET X1="SCREEN <"_+IBSR_">"
+5 ;JWS;IB*2.0*592; Dental
+6 IF $$FT^IBCEF(IBIFN)=7
IF IBSR=8
SET X="DENTAL - CLAIM INFORMATION"
+7 ; IB*2.0*447 BI End
+8 NEW IB0,IBT
SET IB0=$GET(^DGCR(399,IBIFN,0))
SET IBT=$PIECE(IB0,U,19)
SET DGINPT=$SELECT($$INPAT^IBCEF(IBIFN):"Inpat",1:"Outpat")
+9 ;
+10 ; clear screen
WRITE @IOF
+11 ; name
WRITE !,VADM(1)
+12 ; ssn
WRITE " ",$PIECE(VADM(2),"^",2)
+13 ; claim# - type
WRITE " BILL#: ",IBBNO_" - "_DGINPT,"/"
+14 ; form type 2
IF IBT=2
WRITE "1500"
+15 ; form type 3
IF IBT=3
WRITE $TRANSLATE($PIECE($GET(^IBE(353,3,0)),U,1),"-")
+16 ;JWS;IB*2.0*592 US1108 - Dental form 7
+17 ;IA# 2056
+18 ; form type 7 - dental
IF IBT=7
WRITE $$GET1^DIQ(353,"7,",.01)
+19 ; screen#
WRITE ?(80-$LENGTH(X1)),X1
+20 ; separator line
WRITE !,L
+21 ; screen description
WRITE !?(40-($LENGTH(X)\2)),IBVI,X,IBVO
HQ ;
+1 KILL L,DGINPT
+2 QUIT
+3 ;
A ;Format Address(es)
+1 NEW Y
FOR I=IBA1:1:IBA1+2
IF $PIECE(IB(IBAD),U,I)]""
SET IBA(IBA2)=$PIECE(IB(IBAD),U,I)
SET IBA2=IBA2+2
+2 IF IBA2=1
SET IBA(1)="STREET ADDRESS UNKNOWN"
SET IBA2=IBA2+2
+3 SET J=$SELECT($DATA(^DIC(5,+$PIECE(IB(IBAD),U,IBA1+4),0)):$PIECE(^(0),U,2),1:"")
SET J(1)=$PIECE(IB(IBAD),U,IBA1+3)
SET J(2)=$PIECE(IB(IBAD),U,IBA1+11)
SET IBA(IBA2)=$SELECT(J(1)]""&(J]""):J(1)_", "_J,J(1)]"":J(1),J]"":J,1:"CITY/STATE UNKNOWN")
+4 SET Y=$SELECT(IBAD=.11!(IBAD=.121):$PIECE(IB(IBAD),U,IBA1+11),IBAD=.25:$PIECE($GET(^DPT(+$GET(DFN),.22)),U,6),IBAD=.311:$PIECE($GET(^DPT(+$GET(DFN),.22)),U,5),1:"")
DO ZIPOUT^VAFADDR
+5 SET IBA(IBA2)=IBA(IBA2)_" "_Y
FOR I=0:0
SET I=$ORDER(IBA(I))
if I=""
QUIT
SET IBA(I)=$EXTRACT(IBA(I),1,25)
+6 KILL IBA1,I,J
QUIT
