- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m
r613 r623 1 IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35 2 ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;MAP TO DGCRSCE 6 ; always do procedures last because they are edited upon return to screen routine 7 I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54," 8 I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44," 9 LOOP N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20="" D EDIT 10 Q 11 EDIT N IBQUERY 12 I (IBDR20["31") D MCCR^IBCNSP2 G ENQ 13 I (IBDR20["43")!(IBDR20["52") D ^IBCSC4D G ENQ 14 I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL 15 I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ; 16 I (IBDR20["55") D ^IBCSC5A G ENQ 17 I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ 18 I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ 19 I IBDR20["85",$$FT^IBCEF(IBIFN)=2 D ^IBCSC8A G ENQ ; chiropractic data 20 I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ ;UB-04 21 I IBDR20["88",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ ;CMS-1500 22 F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ 23 TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1] 24 S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399," 25 D ^DIE K DIE,DR,DLAYGO 26 I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1) 27 ENQ K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA Q 28 ; 29 ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1 30 ; 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" 31 ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;" 32 ; 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 33 ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q 34 ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q 35 ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q 36 ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q 37 ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q 38 ; Q 39 16 ;;.18; 40 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; 41 310 ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31; 42 32 ;;104;105;106;121;107;108;109 43 41 ;;S:IBPTF Y="@411";159.5;@411;160;159;158; 44 42 ;;162; 45 43 ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43; 46 44 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1 47 45 ;;41; 48 46 ;;40; 49 51 ;;.03; 50 999 ;;64;65;66;67;68; 51 52 ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99; 52 53 ;;;;same as 74 53 54 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1 54 55 ;;41; 55 56 ;;40; 56 61 ;;.06;164; 57 62 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62; 58 63 ;;151;152; 59 64 ;;161;165; 60 65 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65; 61 71 ;;.06;164; 62 72 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72; 63 73 ;;151;152; 64 74 ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT; 65 75 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75; 66 81 ;;208; 67 82 ;;204; 68 83 ;;205; 69 84 ;;206; 70 85 ;;207; 71 86 ;;163; 72 ; 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 73 ; 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 74 ;called by screen 3 (input template) 75 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 76 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) 77 K IBAIC,IBDD,IBI1 Q 78 ; 79 ;Edit patient's address using DGREGAED API 80 EDADDR(IBDFN) ; 81 I $G(IBFLIAE)'=1!(IBDFN=0) Q 0 82 N IBFL S IBFL(1)=1 83 N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR 84 D EN^DGREGAED(IBDFN,.IBFL) 85 Q 1 86 ;IBCSCE 1 IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35 2 ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;MAP TO DGCRSCE 6 ; always do procedures last because they are edited upon return to screen routine 7 I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54," 8 I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44," 9 LOOP N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20="" D EDIT 10 Q 11 EDIT N IBQUERY 12 I (IBDR20["31") D MCCR^IBCNSP2 G ENQ 13 I (IBDR20["43")!(IBDR20["52") D ^IBCSC4D G ENQ 14 I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL 15 I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ; 16 I (IBDR20["55") D ^IBCSC5A G ENQ 17 I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ 18 I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ 19 I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ ;UB-04 20 I IBDR20["87",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ ;CMS-1500 21 F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ 22 TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1] 23 S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399," 24 D ^DIE K DIE,DR,DLAYGO 25 I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1) 26 ENQ K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA Q 27 ; 28 ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1 29 ; 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" 30 ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;" 31 ; 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 32 ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q 33 ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q 34 ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q 35 ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q 36 ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q 37 ; Q 38 16 ;;.18; 39 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; 40 310 ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31; 41 32 ;;104;105;106;121;107;108;109 42 41 ;;S:IBPTF Y="@411";159.5;@411;160;159;158; 43 42 ;;162; 44 43 ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43; 45 44 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1 46 45 ;;41; 47 46 ;;40; 48 51 ;;.03; 49 999 ;;64;65;66;67;68; 50 52 ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99; 51 53 ;;;;same as 74 52 54 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1 53 55 ;;41; 54 56 ;;40; 55 61 ;;.06;164; 56 62 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62; 57 63 ;;151;152; 58 64 ;;161;165; 59 65 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65; 60 71 ;;.06;164; 61 72 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72; 62 73 ;;151;152; 63 74 ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT; 64 75 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75; 65 81 ;;208; 66 82 ;;204; 67 83 ;;205; 68 84 ;;206; 69 85 ;;207; 70 86 ;;163; 71 ; 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 72 ; 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 73 ;called by screen 3 (input template) 74 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 75 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) 76 K IBAIC,IBDD,IBI1 Q 77 ; 78 ;Edit patient's address using DGREGAED API 79 EDADDR(IBDFN) ; 80 I $G(IBFLIAE)'=1!(IBDFN=0) Q 0 81 N IBFL S IBFL(1)=1 82 N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR 83 D EN^DGREGAED(IBDFN,.IBFL) 84 Q 1 85 ;IBCSCE
Note:
See TracChangeset
for help on using the changeset viewer.
