IBCSCE1 ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
;;2.0;INTEGRATED BILLING;**516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRSCE1
;
S:'$D(DR(2,2)) DR(2,2)="" S:'$D(DGDRS1) DGDRS1="DR(2,2)" S:'$D(IB1) IB1=0 S:'$D(DGCT1) DGCT1=0 S DGDRD=$P($T(@J),";;",2) D S S K=(J*10) I $T(@K) S DGDRD=$P($T(@K),";;",2) D S
I +J=31 S DR(3,2.312)=".01;7.02;2;15;8;3;6;S IBADI=X;7.01//^S X=$S(IBADI=""v"":$P(VADM(1),""^"",1),1:"""");16//^S X=$S(IBADI=""v"":""01"",1:"""");"
Q
S I $L(@DGDRS1)+$L(DGDRD)<241 S @DGDRS1=@DGDRS1_DGDRD Q
S DGCT1=DGCT1+1,DGDRS1="DR(2,2,"_DGCT1_")",@DGDRS1=DGDRD Q
Q
11 ;;.03;
12 ;;1;
13 ;;.02;.05;
14 ;;1901;.361;
15 ;;.111;S:X="" Y=.114;.112;S:X="" Y=.114;.113:.117;.131;.12105;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,*7,"But I need a Start Date for this Temporary Address." S Y=.12105;
150 ;;.1218;.1211;I X']"" W !?4,*7,"But I need at least one line of a Temporary address." S Y=.12105;.1212;S:X']"" Y=.1214;.1213;.1214;.1215;.1216;.1219;@15;K DIE("NO^");
21 ;;.07;.31115;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@41";.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3119;@41;
22 ;;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.258;@42;
31 ;;.3121;
AD S X=$S($D(^DPT(DA,.11)):^(.11),1:""),IBPHO=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(IBADD)):^(IBADD),1:""),^(IBADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_IBPHO_U_$P(Y,U,10) K IBADD,IBPHO Q
SET S I(0,0)=D0,Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:""),X=$P(Y(1),"^",2),D(0)=X,X=$S(D(0)>0:D(0),1:"") Q
;IBCSCE1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSCE1 1624 printed Dec 13, 2024@02:20:29 Page 2
IBCSCE1 ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
+1 ;;2.0;INTEGRATED BILLING;**516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSCE1
+5 ;
+6 if '$DATA(DR(2,2))
SET DR(2,2)=""
if '$DATA(DGDRS1)
SET DGDRS1="DR(2,2)"
if '$DATA(IB1)
SET IB1=0
if '$DATA(DGCT1)
SET DGCT1=0
SET DGDRD=$PIECE($TEXT(@J),";;",2)
DO S
SET K=(J*10)
IF $TEXT(@K)
SET DGDRD=$PIECE($TEXT(@K),";;",2)
DO S
+7 IF +J=31
SET DR(3,2.312)=".01;7.02;2;15;8;3;6;S IBADI=X;7.01//^S X=$S(IBADI=""v"":$P(VADM(1),""^"",1),1:"""");16//^S X=$S(IBADI=""v"":""01"",1:"""");"
+8 QUIT
S IF $LENGTH(@DGDRS1)+$LENGTH(DGDRD)<241
SET @DGDRS1=@DGDRS1_DGDRD
QUIT
+1 SET DGCT1=DGCT1+1
SET DGDRS1="DR(2,2,"_DGCT1_")"
SET @DGDRS1=DGDRD
QUIT
+2 QUIT
11 ;;.03;
12 ;;1;
13 ;;.02;.05;
14 ;;1901;.361;
15 ;;.111;S:X="" Y=.114;.112;S:X="" Y=.114;.113:.117;.131;.12105;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,*7,"But I need a Start Date for this Temporary Address." S Y=.12105;
150 ;;.1218;.1211;I X']"" W !?4,*7,"But I need at least one line of a Temporary address." S Y=.12105;.1212;S:X']"" Y=.1214;.1213;.1214;.1215;.1216;.1219;@15;K DIE("NO^");
21 ;;.07;.31115;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@41";.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3119;@41;
22 ;;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.258;@42;
31 ;;.3121;
AD SET X=$SELECT($DATA(^DPT(DA,.11)):^(.11),1:"")
SET IBPHO=$SELECT($DATA(^(.13)):$PIECE(^(.13),U,1),1:"")
SET Y=$SELECT($DATA(^(IBADD)):^(IBADD),1:"")
SET ^(IBADD)=$PIECE(Y,U,1)_U_$PIECE(Y,U,2)_U_$PIECE(X,U,1,6)_U_IBPHO_U_$PIECE(Y,U,10)
KILL IBADD,IBPHO
QUIT
SET SET I(0,0)=D0
SET Y(1)=$SELECT($DATA(^DGCR(399,D0,0)):^(0),1:"")
SET X=$PIECE(Y(1),"^",2)
SET D(0)=X
SET X=$SELECT(D(0)>0:D(0),1:"")
QUIT
+1 ;IBCSCE1
