- IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
- ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371,400,432,447,547,592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, 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 N IBQUERY
- I (IBDR20["31") D MCCR^IBCNSP2 G ENQ
- I (IBDR20["43")!(IBDR20["52") 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 EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ;
- I (IBDR20["55") D ^IBCSC5A G ENQ
- I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ
- I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ
- I IBDR20["102",$$FT^IBCEF(IBIFN)=3 D EN^IBCSC10B G ENQ ; UB-04 patient reason for visit (screen 10, section 2)
- I IBDR20["105",$$FT^IBCEF(IBIFN)=2 D ^IBCSC10A G ENQ ; cms-1500 chiropractic data (screen 10, section 5)
- ;
- ;WCJ;IB*2.0*547
- ;I IBDR20["107",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ ; UB-04 provider ID maintenance (screen 10, section 7)
- I IBDR20["108",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ ; UB-04 provider ID maintenance (screen 10, section 8)
- ;
- ;WCJ;IB*2.0*547
- ;I IBDR20["109",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ ; cms-1500 provider ID maintenance (screen 10, section 9)
- ;JWS;IB*2.0*592 US1108 - Dental form 7
- I IBDR20["110",$$FT^IBCEF(IBIFN)=2!($$FT^IBCEF(IBIFN)=7) D EN1^IBCEP6 G ENQ ; cms-1500 provider ID maintenance (screen 10, section 10); not a misprint it is screen *10 +section which is 110
- ;
- F Q=1:1:9 I IBDR20[("11"_Q) D EDIT^IBCSC11 G ENQ ; IB*2.0*447 BI
- TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1]
- S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399,"
- D ^DIE K DIE,DR,DLAYGO
- I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1)
- ;
- ENQ ;
- K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA
- 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
- ;
- ;Edit patient's address using DGREGAED API
- EDADDR(IBDFN) ;
- I $G(IBFLIAE)'=1!(IBDFN=0) Q 0
- N IBFL S IBFL(1)=1
- N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR
- D EN^DGREGAED(IBDFN,.IBFL)
- Q 1
- ;IBCSCE
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSCE 2882 printed Jan 18, 2025@03:21:40 Page 2
- IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
- +1 ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371,400,432,447,547,592**;21-MAR-94;Build 58
- +2 ;;Per VA Directive 6402, 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 NEW IBQUERY
- +1 IF (IBDR20["31")
- DO MCCR^IBCNSP2
- GOTO ENQ
- +2 IF (IBDR20["43")!(IBDR20["52")
- DO ^IBCSC4D
- GOTO ENQ
- +3 IF (IBDR20["74")!(IBDR20["53")
- KILL DR
- NEW I
- DO ^IBCOPV
- SET (DA,Y)=IBIFN
- GOTO TMPL
- +4 ;
- IF (IBDR20["54")
- IF $PIECE($GET(^IBE(350.9,1,1)),"^",17)
- KILL DR
- NEW I
- DO EN1^IBCCPT(.IBQUERY)
- DO CLOSE^IBSDU(.IBQUERY)
- GOTO TMPL
- +5 IF (IBDR20["55")
- DO ^IBCSC5A
- GOTO ENQ
- +6 IF (IBDR20["45")!(IBDR20["56")
- DO ^IBCSC5B
- GOTO ENQ
- +7 IF (IBDR20["66")!(IBDR20["76")
- DO EDIT^IBCRBE(IBIFN)
- DO ASKCMB^IBCU65(IBIFN)
- GOTO ENQ
- +8 ; UB-04 patient reason for visit (screen 10, section 2)
- IF IBDR20["102"
- IF $$FT^IBCEF(IBIFN)=3
- DO EN^IBCSC10B
- GOTO ENQ
- +9 ; cms-1500 chiropractic data (screen 10, section 5)
- IF IBDR20["105"
- IF $$FT^IBCEF(IBIFN)=2
- DO ^IBCSC10A
- GOTO ENQ
- +10 ;
- +11 ;WCJ;IB*2.0*547
- +12 ;I IBDR20["107",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ ; UB-04 provider ID maintenance (screen 10, section 7)
- +13 ; UB-04 provider ID maintenance (screen 10, section 8)
- IF IBDR20["108"
- IF $$FT^IBCEF(IBIFN)=3
- DO EN1^IBCEP6
- GOTO ENQ
- +14 ;
- +15 ;WCJ;IB*2.0*547
- +16 ;I IBDR20["109",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ ; cms-1500 provider ID maintenance (screen 10, section 9)
- +17 ;JWS;IB*2.0*592 US1108 - Dental form 7
- +18 ; cms-1500 provider ID maintenance (screen 10, section 10); not a misprint it is screen *10 +section which is 110
- IF IBDR20["110"
- IF $$FT^IBCEF(IBIFN)=2!($$FT^IBCEF(IBIFN)=7)
- DO EN1^IBCEP6
- GOTO ENQ
- +19 ;
- +20 ; IB*2.0*447 BI
- FOR Q=1:1:9
- IF IBDR20[("11"_Q)
- DO EDIT^IBCSC11
- GOTO ENQ
- TMPL ;to invoke EN^DGREGAED from [IB SCREEN1]
- NEW IBFLIAE
- SET IBFLIAE=1
- +1 SET DR="[IB SCREEN"_IBSR_IBSR1_"]"
- SET (DA,Y)=IBIFN
- SET DIE="^DGCR(399,"
- +2 DO ^DIE
- KILL DIE,DR,DLAYGO
- +3 IF (IBDR20["61")!(IBDR20["71")
- IF +$GET(DGRVRCAL)
- DO PROC^IBCU7A(IBIFN,1)
- +4 ;
- ENQ ;
- +1 KILL DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA
- +2 QUIT
- +3 ;
- +4 ;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 ;
- +4 ;Edit patient's address using DGREGAED API
- EDADDR(IBDFN) ;
- +1 IF $GET(IBFLIAE)'=1!(IBDFN=0)
- QUIT 0
- +2 NEW IBFL
- SET IBFL(1)=1
- +3 NEW X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR
- +4 DO EN^DGREGAED(IBDFN,.IBFL)
- +5 QUIT 1
- +6 ;IBCSCE