- IBCSCE1 ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, 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;1;2;15;8;3;6;S IBADI=X;17//^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
- IBCSCE1 ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, 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
- SCE1_source.html#xS">SET DR(3,2.312)=".01;1;2;15;8;3;6;SCE1_source.html#xS">S IBADI=X;17//^SCE1_source.html#xS">S X=$SCE1_source.html#xS">S(IBADI=""v"":$P(VADM(1),""^"",1),1:"""");16//^SCE1_source.html#xS">S X=$SCE1_source.html#xS">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
