IBCEFG60 ;ALB/TMP - OUTPUT FORMATTER-FORM FLD ACTION PROCESSING (CONT) ;28-JAN-96
;;2.0;INTEGRATED BILLING;**52,51**;21-MAR-94
;
DELETE ;
N DIR,Y,IB,IBDA,IBDA1,IBDEL,IBAREC,Z,IB0,Q
D FULL^VALM1
S IBDEL=0
D SEL^IBCEFG6(.IBDA)
I $G(IBCEXDA) S IB=0 F S IB=$O(IBDA(IB)) Q:'IB W !! D
.S IBDA=+IBDA(IB),IB0=$G(^IBA(364.6,IBDA,0))
.I $P(IB0,U,2)="N" D NOEDIT^IBCEFG6("DELETE NATIONAL FIELDS FROM",IB) Q
.S Q=$O(^IBA(364.6,"APAR",IBCEXDA,IBDA,""))
. I Q,Q'=IBDA D Q
..W !,*7,"Can't delete this field until all fields associated with it are deleted" D PAUSE^VALM1
.S Z=$S($P(IB0,U,10)'="":" ("_$P(IB0,U,10)_")",1:"")
.K DIR
.S DIR(0)="YA",DIR("A")="Are you sure you want to DELETE LOCAL FORM FIELD #"_IB_Z_": ",DIR("B")="NO",DIR("A",1)="If you delete this form field, its content definition will",DIR("A",2)=" also be deleted"
.D ^DIR K DIR
.Q:$D(DIRUT)!('Y) S IBDEL=1
.S IBDA1=0 F S IBDA1=$O(^IBA(364.7,"B",IBDA,IBDA1)) D Q:'IBDA1
..I 'IBDA1 S DIK="^IBA(364.6,",DA=IBDA D ^DIK W "." Q
..S DIK="^IBA(364.7,",DA=IBDA1 W "." D ^DIK
.W !!,"Form Field #",IB," Deleted"
I IBDEL D PAUSE^VALM1,BLD^IBCEFG5
S VALMBCK="R"
Q
;
EDCHK(DA) ; Perform edit checks on content definition
; DA = ien of entry in file 364.7
; Returns 1 if user decides to re-edit due to warnings,
; 0 if no warnings or user does not want to re-edit
N IBDA,IB0,IBINS,IBTYPE,WARN,IBX,REDO,IBDAP,IBFORM,IBFTYPE
S (WARN,REDO)=0,IB0=$G(^IBA(364.7,DA,0)),IBDA=+IB0,IBDAP=$P($G(^IBA(364.6,+IB0,0)),U,3),IBINS=$P(IB0,U,5),IBTYPE=$P(IB0,U,6)
S IBFORM=+$G(^IBA(364.6,IBDA,0)),IBFTYPE=$P($G(^IBE(353,IBFORM,2)),U,2)
;Check for missing data element/screen prompt
I '$P(IB0,U,3),$P(IB0,U,4)="" S WARN(1)="",WARN=WARN+1
G:'IBDAP ED1
S IBX=0 F S IBX=$O(^IBA(364.6,"APAR",IBFORM,IBDAP,IBX)) Q:'IBX I IBX'=IBDA D
.S IBX1=0 F S IBX1=$O(^IBA(364.7,"B",IBX,IBX1)) Q:'IBX1 S IBX(IBX1)=$G(^IBA(364.7,IBX1,0))
G:$O(IBX(""))="" ED1 ;No other override flds for the parent field
;Check for 2 fields for same ins co/bill type
; for same ins co/both bill type
; for same bill type/all ins companies
; for both bill type/all ins companies
S IBX=0 F S IBX=$O(IBX(IBX)) Q:'IBX I $P(IBX(IBX),U,5)=IBINS,$P(IBX(IBX),U,6)=IBTYPE D Q:$G(WARN(2))'=""
. I 'IBINS,IBTYPE="",+IBX(IBX)=IBDAP Q ; O/RIDE of 'ALL' default
. S WARN(2)=$S(IBINS:IBINS,1:"ALL")_U_$S(IBTYPE'="":IBTYPE,1:"BOTH"),WARN=WARN+1 Q
ED1 I $O(WARN("")) D
.W !!,*7,"The following problem",$S('WARN:"",1:"s")," exist for this definition:"
.I $D(WARN(1)) W !," * DATA ELEMENT",$S(IBFTYPE'="S":" ",1:" OR SCREEN PROMPT "),"FOR FIELD IS MISSING - NO DATA WILL BE OUTPUT"
.I $D(WARN(2)) W !," * MORE THAN ONE OVERRIDE FLD DEFINITION EXISTS FOR THE ASSOC FIELD FOR:",!,$J("",13),"INS CO: ",$$INS($P(WARN(2),U)),!,$J("",10),"BILL TYPE: ",$$BTYPE($P(WARN(2),U,2))
.W !!,"WANT TO RE-EDIT THIS RECORD NOW?" S %=1 D YN^DICN S REDO=(%+1#3)
Q REDO
;
BTYPE(X) ;RETURN INPT/OUTPT/ALL FOR BILL TYPE CODE IN X
Q $S(X="BOTH":X,X="I":"INPT",X="O":"OUTPT",1:"??")
;
INS(X) ;RETURN NAME OF INSURANCE CO FOR CODE IN X
Q $S(X="ALL":X,$P($G(^DIC(36,+X,0)),U)'="":$P(^(0),U),1:"??")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFG60 3238 printed Dec 13, 2024@02:10:34 Page 2
IBCEFG60 ;ALB/TMP - OUTPUT FORMATTER-FORM FLD ACTION PROCESSING (CONT) ;28-JAN-96
+1 ;;2.0;INTEGRATED BILLING;**52,51**;21-MAR-94
+2 ;
DELETE ;
+1 NEW DIR,Y,IB,IBDA,IBDA1,IBDEL,IBAREC,Z,IB0,Q
+2 DO FULL^VALM1
+3 SET IBDEL=0
+4 DO SEL^IBCEFG6(.IBDA)
+5 IF $GET(IBCEXDA)
SET IB=0
FOR
SET IB=$ORDER(IBDA(IB))
if 'IB
QUIT
WRITE !!
Begin DoDot:1
+6 SET IBDA=+IBDA(IB)
SET IB0=$GET(^IBA(364.6,IBDA,0))
+7 IF $PIECE(IB0,U,2)="N"
DO NOEDIT^IBCEFG6("DELETE NATIONAL FIELDS FROM",IB)
QUIT
+8 SET Q=$ORDER(^IBA(364.6,"APAR",IBCEXDA,IBDA,""))
+9 IF Q
IF Q'=IBDA
Begin DoDot:2
+10 WRITE !,*7,"Can't delete this field until all fields associated with it are deleted"
DO PAUSE^VALM1
End DoDot:2
QUIT
+11 SET Z=$SELECT($PIECE(IB0,U,10)'="":" ("_$PIECE(IB0,U,10)_")",1:"")
+12 KILL DIR
+13 SET DIR(0)="YA"
SET DIR("A")="Are you sure you want to DELETE LOCAL FORM FIELD #"_IB_Z_": "
SET DIR("B")="NO"
SET DIR("A",1)="If you delete this form field, its content definition will"
SET DIR("A",2)=" also be deleted"
+14 DO ^DIR
KILL DIR
+15 if $DATA(DIRUT)!('Y)
QUIT
SET IBDEL=1
+16 SET IBDA1=0
FOR
SET IBDA1=$ORDER(^IBA(364.7,"B",IBDA,IBDA1))
Begin DoDot:2
+17 IF 'IBDA1
SET DIK="^IBA(364.6,"
SET DA=IBDA
DO ^DIK
WRITE "."
QUIT
+18 SET DIK="^IBA(364.7,"
SET DA=IBDA1
WRITE "."
DO ^DIK
End DoDot:2
if 'IBDA1
QUIT
+19 WRITE !!,"Form Field #",IB," Deleted"
End DoDot:1
+20 IF IBDEL
DO PAUSE^VALM1
DO BLD^IBCEFG5
+21 SET VALMBCK="R"
+22 QUIT
+23 ;
EDCHK(DA) ; Perform edit checks on content definition
+1 ; DA = ien of entry in file 364.7
+2 ; Returns 1 if user decides to re-edit due to warnings,
+3 ; 0 if no warnings or user does not want to re-edit
+4 NEW IBDA,IB0,IBINS,IBTYPE,WARN,IBX,REDO,IBDAP,IBFORM,IBFTYPE
+5 SET (WARN,REDO)=0
SET IB0=$GET(^IBA(364.7,DA,0))
SET IBDA=+IB0
SET IBDAP=$PIECE($GET(^IBA(364.6,+IB0,0)),U,3)
SET IBINS=$PIECE(IB0,U,5)
SET IBTYPE=$PIECE(IB0,U,6)
+6 SET IBFORM=+$GET(^IBA(364.6,IBDA,0))
SET IBFTYPE=$PIECE($GET(^IBE(353,IBFORM,2)),U,2)
+7 ;Check for missing data element/screen prompt
+8 IF '$PIECE(IB0,U,3)
IF $PIECE(IB0,U,4)=""
SET WARN(1)=""
SET WARN=WARN+1
+9 if 'IBDAP
GOTO ED1
+10 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(364.6,"APAR",IBFORM,IBDAP,IBX))
if 'IBX
QUIT
IF IBX'=IBDA
Begin DoDot:1
+11 SET IBX1=0
FOR
SET IBX1=$ORDER(^IBA(364.7,"B",IBX,IBX1))
if 'IBX1
QUIT
SET IBX(IBX1)=$GET(^IBA(364.7,IBX1,0))
End DoDot:1
+12 ;No other override flds for the parent field
if $ORDER(IBX(""))=""
GOTO ED1
+13 ;Check for 2 fields for same ins co/bill type
+14 ; for same ins co/both bill type
+15 ; for same bill type/all ins companies
+16 ; for both bill type/all ins companies
+17 SET IBX=0
FOR
SET IBX=$ORDER(IBX(IBX))
if 'IBX
QUIT
IF $PIECE(IBX(IBX),U,5)=IBINS
IF $PIECE(IBX(IBX),U,6)=IBTYPE
Begin DoDot:1
+18 ; O/RIDE of 'ALL' default
IF 'IBINS
IF IBTYPE=""
IF +IBX(IBX)=IBDAP
QUIT
+19 SET WARN(2)=$SELECT(IBINS:IBINS,1:"ALL")_U_$SELECT(IBTYPE'="":IBTYPE,1:"BOTH")
SET WARN=WARN+1
QUIT
End DoDot:1
if $GET(WARN(2))'=""
QUIT
ED1 IF $ORDER(WARN(""))
Begin DoDot:1
+1 WRITE !!,*7,"The following problem",$SELECT('WARN:"",1:"s")," exist for this definition:"
+2 IF $DATA(WARN(1))
WRITE !," * DATA ELEMENT",$SELECT(IBFTYPE'="S":" ",1:" OR SCREEN PROMPT "),"FOR FIELD IS MISSING - NO DATA WILL BE OUTPUT"
+3 IF $DATA(WARN(2))
WRITE !," * MORE THAN ONE OVERRIDE FLD DEFINITION EXISTS FOR THE ASSOC FIELD FOR:",!,$JUSTIFY("",13),"INS CO: ",$$INS($PIECE(WARN(2),U)),!,$JUSTIFY("",10),"BILL TYPE: ",$$BTYPE($PIECE(WARN(2),U,2))
+4 WRITE !!,"WANT TO RE-EDIT THIS RECORD NOW?"
SET %=1
DO YN^DICN
SET REDO=(%+1#3)
End DoDot:1
+5 QUIT REDO
+6 ;
BTYPE(X) ;RETURN INPT/OUTPT/ALL FOR BILL TYPE CODE IN X
+1 QUIT $SELECT(X="BOTH":X,X="I":"INPT",X="O":"OUTPT",1:"??")
+2 ;
INS(X) ;RETURN NAME OF INSURANCE CO FOR CODE IN X
+1 QUIT $SELECT(X="ALL":X,$PIECE($GET(^DIC(36,+X,0)),U)'="":$PIECE(^(0),U),1:"??")
+2 ;
