- IBCSCE ;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 DGCRSCE
- ; always do procedures last because they are edited upon return to screen routine
- I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54,"
- I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44,"
- LOOP N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20="" D EDIT
- Q
- EDIT I (IBDR20["31") D MCCR^IBCNSP2 G ENQ
- I (IBDR20["43")!(IBDR20["52") D:+$G(IBPTF) DX^IBCSC4B D ^IBCSC4D G ENQ
- I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL
- I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D ^IBCCPT G TMPL ; S DR(2,399.0304)=".01;1"
- I (IBDR20["55") D ^IBCSC5A G ENQ
- I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ
- ;S Y="" I "8"[IBSR,$P(^DGCR(399,IBIFN,0),"^",19)=2 S Y="H"
- ;S DR="[IB SCREEN"_IBSR_Y_"]",(DA,Y)=IBIFN,DIE="^DGCR(399,"
- TMPL S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399,"
- D ^DIE K DIE,DR
- ENQ K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA Q
- ;
- ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1
- ; I "^44^"[("^"_J_"^") S DR(2,399.0304)=".01;1;I $D(IBIP),X<$P(IBIP,""^"",2)!($P(IBIP,""^"",6)&(X>$P(IBIP,""^"",6))) K X"
- ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;"
- ; I $T(@J) S DGDRD=$P($T(@J),";;",2) D S S K=(J*10) I $T(@K) S DGDRD=$P($T(@K),";;",2) D S
- ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q
- ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q
- ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q
- ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
- ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q
- ; Q
- 16 ;;110;
- 17 ;;.18;
- 31 ;;.07;S X=$P(^DGCR(399,DA,0),U,11);S Y="@"_$S(X']"":31,X="p":31,X="o":311,1:310);@310;D 1^IBCSCH1 S Y="@"_$S(IBADI=-1:31,'IBADI:312,1:313);@313;^2^DPT(^^D SET^IBCSCE;D UPDT^IBCSCE;@312;
- 310 ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31;
- 32 ;;104;105;106;121;107;108;109
- 41 ;;160;159;158;
- 42 ;;162;
- 43 ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43;
- 44 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1
- 45 ;;41;
- 46 ;;40;
- 51 ;;.03;
- 999 ;;64;65;66;67;68;
- 52 ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99;
- 53 ;;;;same as 74
- 54 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1
- 55 ;;41;
- 56 ;;40;
- 61 ;;.06;164;
- 62 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62;
- 63 ;;151;152;
- 64 ;;161;165;
- 65 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65;
- 71 ;;.06;164;
- 72 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72;
- 73 ;;151;152;
- 74 ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT;
- 75 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75;
- 81 ;;208;
- 82 ;;204;
- 83 ;;205;
- 84 ;;206;
- 85 ;;207;
- 86 ;;163;
- ; 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
- ;called by screen 3 (input template)
- UPDT F IBDD=0:0 S IBDD=$O(^DPT(DFN,.312,IBDD)) Q:IBDD'>0 S IBI1=^DPT(DFN,.312,IBDD,0) I $D(^DIC(36,+IBI1,0)),$P(^(0),"^",2)'="N" S IBDD(+IBI1)=IBI1
- F IBAIC=0:0 S IBAIC=$O(^DGCR(399,IBIFN,"AIC",IBAIC)) Q:IBAIC'>0 I $D(IBDD(IBAIC)) F IBI1="I1","I2","I3" I $D(^DGCR(399,IBIFN,IBI1)),+^(IBI1)=IBAIC,^(IBI1)'=IBDD(IBAIC) S ^DGCR(399,IBIFN,IBI1)=IBDD(IBAIC)
- K IBAIC,IBDD,IBI1 Q
- ;IBCSCE
- IBCSCE ;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 DGCRSCE
- +5 ; always do procedures last because they are edited upon return to screen routine
- +6 IF IBDR20["54,"
- SET IBDR20=$PIECE(IBDR20,"54,",1)_$PIECE(IBDR20,"54,",2)_"54,"
- +7 IF IBDR20["44,"
- SET IBDR20=$PIECE(IBDR20,"44,",1)_$PIECE(IBDR20,"44,",2)_"44,"
- LOOP NEW IBDRLP,IBDRL
- SET IBDRLP=IBDR20
- FOR IBDRL=1:1
- SET IBDR20=$PIECE(IBDRLP,",",IBDRL)
- IF IBDR20=""
- QUIT
- DO EDIT
- +1 QUIT
- EDIT IF (IBDR20["31")
- DO MCCR^IBCNSP2
- GOTO ENQ
- +1 IF (IBDR20["43")!(IBDR20["52")
- IF +$GET(IBPTF)
- DO DX^IBCSC4B
- DO ^IBCSC4D
- GOTO ENQ
- +2 IF (IBDR20["74")!(IBDR20["53")
- KILL DR
- NEW I
- DO ^IBCOPV
- SET (DA,Y)=IBIFN
- GOTO TMPL
- +3 ; S DR(2,399.0304)=".01;1"
- IF (IBDR20["54")
- IF $PIECE($GET(^IBE(350.9,1,1)),"^",17)
- KILL DR
- NEW I
- DO ^IBCCPT
- GOTO TMPL
- +4 IF (IBDR20["55")
- DO ^IBCSC5A
- GOTO ENQ
- +5 IF (IBDR20["45")!(IBDR20["56")
- DO ^IBCSC5B
- GOTO ENQ
- +6 ;S Y="" I "8"[IBSR,$P(^DGCR(399,IBIFN,0),"^",19)=2 S Y="H"
- +7 ;S DR="[IB SCREEN"_IBSR_Y_"]",(DA,Y)=IBIFN,DIE="^DGCR(399,"
- TMPL SET DR="[IB SCREEN"_IBSR_IBSR1_"]"
- SET (DA,Y)=IBIFN
- SET DIE="^DGCR(399,"
- +1 DO ^DIE
- KILL DIE,DR
- ENQ KILL DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA
- QUIT
- +1 ;
- +2 ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1
- +3 ; I "^44^"[("^"_J_"^") S DR(2,399.0304)=".01;1;I $D(IBIP),X<$P(IBIP,""^"",2)!($P(IBIP,""^"",6)&(X>$P(IBIP,""^"",6))) K X"
- +4 ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;"
- +5 ; I $T(@J) S DGDRD=$P($T(@J),";;",2) D S S K=(J*10) I $T(@K) S DGDRD=$P($T(@K),";;",2) D S
- +6 ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q
- +7 ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q
- +8 ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q
- +9 ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
- +10 ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q
- +11 ; Q
- 16 ;;110;
- 17 ;;.18;
- 31 ;;.07;S X=$P(^DGCR(399,DA,0),U,11);S Y="@"_$S(X']"":31,X="p":31,X="o":311,1:310);@310;D 1^IBCSCH1 S Y="@"_$S(IBADI=-1:31,'IBADI:312,1:313);@313;^2^DPT(^^D SET^IBCSCE;D UPDT^IBCSCE;@312;
- 310 ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31;
- 32 ;;104;105;106;121;107;108;109
- 41 ;;160;159;158;
- 42 ;;162;
- 43 ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43;
- 44 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1
- 45 ;;41;
- 46 ;;40;
- 51 ;;.03;
- 999 ;;64;65;66;67;68;
- 52 ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99;
- 53 ;;;;same as 74
- 54 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1
- 55 ;;41;
- 56 ;;40;
- 61 ;;.06;164;
- 62 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62;
- 63 ;;151;152;
- 64 ;;161;165;
- 65 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65;
- 71 ;;.06;164;
- 72 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72;
- 73 ;;151;152;
- 74 ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT;
- 75 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75;
- 81 ;;208;
- 82 ;;204;
- 83 ;;205;
- 84 ;;206;
- 85 ;;207;
- 86 ;;163;
- +1 ; 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
- +2 ; 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
- +3 ;called by screen 3 (input template)
- UPDT FOR IBDD=0:0
- SET IBDD=$ORDER(^DPT(DFN,.312,IBDD))
- IF IBDD'>0
- QUIT
- SET IBI1=^DPT(DFN,.312,IBDD,0)
- IF $DATA(^DIC(36,+IBI1,0))
- IF $PIECE(^(0),"^",2)'="N"
- SET IBDD(+IBI1)=IBI1
- +1 FOR IBAIC=0:0
- SET IBAIC=$ORDER(^DGCR(399,IBIFN,"AIC",IBAIC))
- IF IBAIC'>0
- QUIT
- IF $DATA(IBDD(IBAIC))
- FOR IBI1="I1","I2","I3"
- IF $DATA(^DGCR(399,IBIFN,IBI1))
- IF +^(IBI1)=IBAIC
- IF ^(IBI1)'=IBDD(IBAIC)
- SET ^DGCR(399,IBIFN,IBI1)=IBDD(IBAIC)
- +2 KILL IBAIC,IBDD,IBI1
- QUIT
- +3 ;IBCSCE
