IBCEFG4 ;ALB/TMP - OUTPUT FORMATTER MAINTENANCE - FORM ACTION PROCESSING ;22-JAN-96
;;2.0;INTEGRATED BILLING;**52,51,320**;21-MAR-94
;
ADDL ; Add a new local form
N IBCT,IBDA,IBNAME,IBTYPE,IBBASE,IBNEW6,IBNEW7,IBOLD,IBOLD6,IBOLD7,LAST6,LAST7,DIR,X,Y,DD,DO,DIE,DR,DA,Z,Z0,Z1
D FULL^VALM1
S DIR("A")="Enter a new LOCAL FORM NAME: ",DIR(0)="FA^1:30^D @(""DUPNM""_$C(94)_""IBCEFG4"")",DIR("?")="Enter the name that you want your new local form to be referenced by" D ^DIR K DIR
G:$D(DIRUT) ADDLQ
S IBNAME=Y
ADDL1 S DIR("A")="Enter form number (must be > 9999): ",DIR(0)="NA^9999:999999999^D @(""DUPNUM""_$C(94)_""IBCEFG4"")"
S DIR("?")="Enter the internal entry number that will be assigned to this form",DIR("B")=$O(^IBE(353,"A"),-1)+1 S:DIR("B")<10000 DIR("B")=10000 D ^DIR K DIR
G:$D(DIRUT) ADDLQ
S IBDA=+Y L +^IBE(353,IBDA):5 I '$T W !,*7,"Another user has taken this number ... please select a new one." G ADDL1
K DD,DO
S DIC="^IBE(353,",DIC(0)="L",DLAYGO=353,DIC("DR")="2.04////0;@10;2.01;I X="""" W !,*7,""MUST HAVE A BASE FILE!!"" S Y=""@10"";@20;2.02;I X="""" W !,*7,""MUST HAVE A FORMAT TYPE!!"" S Y=""@20""",DINUM=IBDA,X=IBNAME D FILE^DICN K DO,DD,DLAYGO
S $P(^IBE(353,0),U,3)=$O(^IBE(353,9999),-1) L -^IBE(353,IBDA)
G:Y<0 ADDLQ
W !!,"WANT TO ASSOCIATE THIS FORM WITH A NATIONAL FORM" S %=2 D YN^DICN G:'(%+1#3) ADDL2
K % W !
S DIE="^IBE(353,",DR="2.05",DA=IBDA D ^DIE W !
I '$P($G(^IBE(353,IBDA,2)),U,5) W !,*7,"FORM NOT ASSOCIATED WITH ANY NATIONAL FORM"
G ADDLQ
ADDL2 W !!,"WANT TO COPY ALL FIELDS FROM AN EXISTING FORM" S %=2 D YN^DICN G:'(%+1#3) ADDLQ
S DIC="^IBE(353,",DIC(0)="AEMQ",DIC("A")="Select FORM TO COPY FROM: ",DIC("S")="I $P($G(^(2)),U,5)="""",$P($G(^IBE(353,"_IBDA_",2)),U,2)=$P($G(^IBE(353,Y,2)),U,2),+$G(^IBE(353,"_IBDA_",2))=+$G(^IBE(353,Y,2)),Y'="_IBDA D ^DIC K DIC
G:Y<0 ADDL2 S IBOLD=+Y
W !,"ARE YOU SURE YOU WANT TO MAKE THIS COPY" S %=2 D YN^DICN G:'(%+1#3) ADDLQ
W !!,"This may take a little while ... please be patient while I build your new form"
;
; IB*2*320
; Make sure files 364.6 and 364.7 are set-up to add new entries in the
; local number range (greater than 10000). We cannot allow these local
; entries to get added into the national number range.
F Z=364.6,364.7 I $P($G(^IBA(Z,0)),U,3)<10000 D
. N IBLAST S IBLAST=$O(^IBA(Z," "),-1)
. I IBLAST<10000 S IBLAST=10000
. S $P(^IBA(Z,0),U,3)=IBLAST
. Q
;
K ^TMP("IBX",$J)
S Z=0 F S Z=$O(^IBA(364.6,"APAR",IBOLD,Z)) Q:'Z S Z0=0 F S Z0=$O(^IBA(364.6,"APAR",IBOLD,Z,Z0)) Q:'Z0 S ^TMP("IBX",$J,1,Z0)=Z,^TMP("IBX",$J,2,Z)=Z0 ;Save off overrides
;
S LAST6=+$O(^DD(364.6,"GL",0,""),-1),LAST7=+$O(^DD(364.7,"GL",0,""),-1),IBCT=0
S IBOLD6=0 F S IBOLD6=$O(^IBA(364.6,"B",IBOLD,IBOLD6)) Q:'IBOLD6 S IBNEW6=$$NEW(6,IBDA) I IBNEW6 S IBCT=IBCT+1,Z=$G(^IBA(364.6,IBOLD6,0)) D
.S $P(^IBA(364.6,IBNEW6,0),U,4,LAST6)=$P(Z,U,4,LAST6)
.;
.I $D(^TMP("IBX",$J,2,IBOLD6)) S Z0=^(IBOLD6) D ;parent record
..I '$D(^TMP("IBX",$J,1,+Z0,1)) S ^TMP("IBX",$J,2,IBOLD6,1)=IBNEW6 Q
..S Z1=^TMP("IBX",$J,1,+Z0,1),$P(^IBA(364.6,Z1,0),U,3)=IBNEW6,DIK="^IBA(364.6,",DA=Z1,DIK(1)=.03 D EN^DIK K DIK
.I $P(Z,U,3) D ;child record
..I $G(^TMP("IBX",$J,2,$P(Z,U,3),1)) S $P(^IBA(364.6,IBNEW6,0),U,3)=^TMP("IBX",$J,2,$P(Z,U,3),1) Q
..S ^TMP("IBX",$J,1,IBOLD6,1)=IBNEW6
.;
.S DA=IBNEW6,DIK="^IBA(364.6," D IX1^DIK
.S IBOLD7=$O(^IBA(364.7,"B",IBOLD6,"")) Q:'IBOLD7
.S IBNEW7=$$NEW(7,IBNEW6) Q:'IBNEW7
.S $P(^IBA(364.7,IBNEW7,0),U,3,LAST7)=$P(^IBA(364.7,IBOLD7,0),U,3,LAST7)
.I $G(^IBA(364.7,IBOLD7,1))'="" S ^IBA(364.7,IBNEW7,1)=^IBA(364.7,IBOLD7,1)
.S DA=IBNEW7,DIK="^IBA(364.7," D IX1^DIK
K ^TMP("IBX",$J)
W !!,"Field copy completed - ",IBCT," fields copied",!!
ADDLQ I $G(IBDA) D EDITL(IBDA),BLD^IBCEFG3
S VALMBCK="R"
Q
;
NEW(FILE,KEY) ; Add a new local entry to file 364.FILE whose .01 field is KEY
; RETURN IEN OF NEW ENTRY OR 0 IF NONE ADDED
K DO,DD
S DLAYGO=364_"."_FILE,DIC="^IBA(364."_FILE_",",DIC("DR")=".02////L",X=KEY,DIC(0)="L"
D FILE^DICN K DIC,DD,DO,DLAYGO
W "."
Q $S(Y>0:+Y,1:0)
;
EDIT ; Edit a local form
D FULL^VALM1
D:$G(IBCEXDA) EDITL(IBCEXDA),BLDX^IBCEFG3
S VALMBCK=$S($D(^IBE(353,+$G(IBCEXDA))):"R",1:"Q")
Q
;
EDITL(DA) ; Edit a local form whose entry number is DA
S DIE="^IBE(353,",DR="[IBCE ADD/EDIT LOCAL FORM]" D ^DIE
Q
;
FFLDS ; Edit Local Form Fields
D FULL^VALM1
D EN^VALM("IBCE FORM FIELDS LIST")
S VALMBCK="R"
Q
;
CHGFORM ; Select a new form without going back a screen
N DIC,DA
D FULL^VALM1
S DIC="^IBE(353,",DIC("S")="I $P($G(^(2)),U,4)=0",DIC(0)="AEMQ" D ^DIC
I Y>0 S IBCEXDA=+Y D HDRX^IBCEFG3,BLDX^IBCEFG3
S VALMBCK="R"
Q
;
FASTEXIT ; Sets a flag that system should be exited
S VALMBCK="Q"
I $G(VALMEVL) D ;Ask this for all but the last level
.D FULL^VALM1
.K DIR S DIR(0)="Y",DIR("A")="Exit option entirely",DIR("B")="NO" D ^DIR K DIR
.I $D(DIRUT)!(Y) S IBFASTXT=1
Q
;
DUPNM ;
I $D(^IBE(353,"B",X)) K X W !,*7,"A form with this name already exists"
Q
;
DUPNUM ;
I $D(^IBE(353,X)) K X W !,*7,"A form with this number already exists"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFG4 5138 printed Oct 16, 2024@18:11:11 Page 2
IBCEFG4 ;ALB/TMP - OUTPUT FORMATTER MAINTENANCE - FORM ACTION PROCESSING ;22-JAN-96
+1 ;;2.0;INTEGRATED BILLING;**52,51,320**;21-MAR-94
+2 ;
ADDL ; Add a new local form
+1 NEW IBCT,IBDA,IBNAME,IBTYPE,IBBASE,IBNEW6,IBNEW7,IBOLD,IBOLD6,IBOLD7,LAST6,LAST7,DIR,X,Y,DD,DO,DIE,DR,DA,Z,Z0,Z1
+2 DO FULL^VALM1
+3 SET DIR("A")="Enter a new LOCAL FORM NAME: "
SET DIR(0)="FA^1:30^D @(""DUPNM""_$C(94)_""IBCEFG4"")"
SET DIR("?")="Enter the name that you want your new local form to be referenced by"
DO ^DIR
KILL DIR
+4 if $DATA(DIRUT)
GOTO ADDLQ
+5 SET IBNAME=Y
ADDL1 SET DIR("A")="Enter form number (must be > 9999): "
SET DIR(0)="NA^9999:999999999^D @(""DUPNUM""_$C(94)_""IBCEFG4"")"
+1 SET DIR("?")="Enter the internal entry number that will be assigned to this form"
SET DIR("B")=$ORDER(^IBE(353,"A"),-1)+1
if DIR("B")<10000
SET DIR("B")=10000
DO ^DIR
KILL DIR
+2 if $DATA(DIRUT)
GOTO ADDLQ
+3 SET IBDA=+Y
LOCK +^IBE(353,IBDA):5
IF '$TEST
WRITE !,*7,"Another user has taken this number ... please select a new one."
GOTO ADDL1
+4 KILL DD,DO
+5 SET DIC="^IBE(353,"
SET DIC(0)="L"
SET DLAYGO=353
SET DIC("DR")="2.04////0;@10;2.01;I X="""" W !,*7,""MUST HAVE A BASE FILE!!"" S Y=""@10"";@20;2.02;I X="""" W !,*7,""MUST HAVE A FORMAT TYPE!!"" S Y=""@20"""
SET DINUM=IBDA
SET X=IBNAME
DO FILE^DICN
KILL DO,DD,DLAYGO
+6 SET $PIECE(^IBE(353,0),U,3)=$ORDER(^IBE(353,9999),-1)
LOCK -^IBE(353,IBDA)
+7 if Y<0
GOTO ADDLQ
+8 WRITE !!,"WANT TO ASSOCIATE THIS FORM WITH A NATIONAL FORM"
SET %=2
DO YN^DICN
if '(%+1#3)
GOTO ADDL2
+9 KILL %
WRITE !
+10 SET DIE="^IBE(353,"
SET DR="2.05"
SET DA=IBDA
DO ^DIE
WRITE !
+11 IF '$PIECE($GET(^IBE(353,IBDA,2)),U,5)
WRITE !,*7,"FORM NOT ASSOCIATED WITH ANY NATIONAL FORM"
+12 GOTO ADDLQ
ADDL2 WRITE !!,"WANT TO COPY ALL FIELDS FROM AN EXISTING FORM"
SET %=2
DO YN^DICN
if '(%+1#3)
GOTO ADDLQ
+1 SET DIC="^IBE(353,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select FORM TO COPY FROM: "
SET DIC("S")="I $P($G(^(2)),U,5)="""",$P($G(^IBE(353,"_IBDA_",2)),U,2)=$P($G(^IBE(353,Y,2)),U,2),+$G(^IBE(353,"_IBDA_",2))=+$G(^IBE(353,Y,2)),Y'="_IBDA
DO ^DIC
KILL DIC
+2 if Y<0
GOTO ADDL2
SET IBOLD=+Y
+3 WRITE !,"ARE YOU SURE YOU WANT TO MAKE THIS COPY"
SET %=2
DO YN^DICN
if '(%+1#3)
GOTO ADDLQ
+4 WRITE !!,"This may take a little while ... please be patient while I build your new form"
+5 ;
+6 ; IB*2*320
+7 ; Make sure files 364.6 and 364.7 are set-up to add new entries in the
+8 ; local number range (greater than 10000). We cannot allow these local
+9 ; entries to get added into the national number range.
+10 FOR Z=364.6,364.7
IF $PIECE($GET(^IBA(Z,0)),U,3)<10000
Begin DoDot:1
+11 NEW IBLAST
SET IBLAST=$ORDER(^IBA(Z," "),-1)
+12 IF IBLAST<10000
SET IBLAST=10000
+13 SET $PIECE(^IBA(Z,0),U,3)=IBLAST
+14 QUIT
End DoDot:1
+15 ;
+16 KILL ^TMP("IBX",$JOB)
+17 ;Save off overrides
SET Z=0
FOR
SET Z=$ORDER(^IBA(364.6,"APAR",IBOLD,Z))
if 'Z
QUIT
SET Z0=0
FOR
SET Z0=$ORDER(^IBA(364.6,"APAR",IBOLD,Z,Z0))
if 'Z0
QUIT
SET ^TMP("IBX",$JOB,1,Z0)=Z
SET ^TMP("IBX",$JOB,2,Z)=Z0
+18 ;
+19 SET LAST6=+$ORDER(^DD(364.6,"GL",0,""),-1)
SET LAST7=+$ORDER(^DD(364.7,"GL",0,""),-1)
SET IBCT=0
+20 SET IBOLD6=0
FOR
SET IBOLD6=$ORDER(^IBA(364.6,"B",IBOLD,IBOLD6))
if 'IBOLD6
QUIT
SET IBNEW6=$$NEW(6,IBDA)
IF IBNEW6
SET IBCT=IBCT+1
SET Z=$GET(^IBA(364.6,IBOLD6,0))
Begin DoDot:1
+21 SET $PIECE(^IBA(364.6,IBNEW6,0),U,4,LAST6)=$PIECE(Z,U,4,LAST6)
+22 ;
+23 ;parent record
IF $DATA(^TMP("IBX",$JOB,2,IBOLD6))
SET Z0=^(IBOLD6)
Begin DoDot:2
+24 IF '$DATA(^TMP("IBX",$JOB,1,+Z0,1))
SET ^TMP("IBX",$JOB,2,IBOLD6,1)=IBNEW6
QUIT
+25 SET Z1=^TMP("IBX",$JOB,1,+Z0,1)
SET $PIECE(^IBA(364.6,Z1,0),U,3)=IBNEW6
SET DIK="^IBA(364.6,"
SET DA=Z1
SET DIK(1)=.03
DO EN^DIK
KILL DIK
End DoDot:2
+26 ;child record
IF $PIECE(Z,U,3)
Begin DoDot:2
+27 IF $GET(^TMP("IBX",$JOB,2,$PIECE(Z,U,3),1))
SET $PIECE(^IBA(364.6,IBNEW6,0),U,3)=^TMP("IBX",$JOB,2,$PIECE(Z,U,3),1)
QUIT
+28 SET ^TMP("IBX",$JOB,1,IBOLD6,1)=IBNEW6
End DoDot:2
+29 ;
+30 SET DA=IBNEW6
SET DIK="^IBA(364.6,"
DO IX1^DIK
+31 SET IBOLD7=$ORDER(^IBA(364.7,"B",IBOLD6,""))
if 'IBOLD7
QUIT
+32 SET IBNEW7=$$NEW(7,IBNEW6)
if 'IBNEW7
QUIT
+33 SET $PIECE(^IBA(364.7,IBNEW7,0),U,3,LAST7)=$PIECE(^IBA(364.7,IBOLD7,0),U,3,LAST7)
+34 IF $GET(^IBA(364.7,IBOLD7,1))'=""
SET ^IBA(364.7,IBNEW7,1)=^IBA(364.7,IBOLD7,1)
+35 SET DA=IBNEW7
SET DIK="^IBA(364.7,"
DO IX1^DIK
End DoDot:1
+36 KILL ^TMP("IBX",$JOB)
+37 WRITE !!,"Field copy completed - ",IBCT," fields copied",!!
ADDLQ IF $GET(IBDA)
DO EDITL(IBDA)
DO BLD^IBCEFG3
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
NEW(FILE,KEY) ; Add a new local entry to file 364.FILE whose .01 field is KEY
+1 ; RETURN IEN OF NEW ENTRY OR 0 IF NONE ADDED
+2 KILL DO,DD
+3 SET DLAYGO=364_"."_FILE
SET DIC="^IBA(364."_FILE_","
SET DIC("DR")=".02////L"
SET X=KEY
SET DIC(0)="L"
+4 DO FILE^DICN
KILL DIC,DD,DO,DLAYGO
+5 WRITE "."
+6 QUIT $SELECT(Y>0:+Y,1:0)
+7 ;
EDIT ; Edit a local form
+1 DO FULL^VALM1
+2 if $GET(IBCEXDA)
DO EDITL(IBCEXDA)
DO BLDX^IBCEFG3
+3 SET VALMBCK=$SELECT($DATA(^IBE(353,+$GET(IBCEXDA))):"R",1:"Q")
+4 QUIT
+5 ;
EDITL(DA) ; Edit a local form whose entry number is DA
+1 SET DIE="^IBE(353,"
SET DR="[IBCE ADD/EDIT LOCAL FORM]"
DO ^DIE
+2 QUIT
+3 ;
FFLDS ; Edit Local Form Fields
+1 DO FULL^VALM1
+2 DO EN^VALM("IBCE FORM FIELDS LIST")
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
CHGFORM ; Select a new form without going back a screen
+1 NEW DIC,DA
+2 DO FULL^VALM1
+3 SET DIC="^IBE(353,"
SET DIC("S")="I $P($G(^(2)),U,4)=0"
SET DIC(0)="AEMQ"
DO ^DIC
+4 IF Y>0
SET IBCEXDA=+Y
DO HDRX^IBCEFG3
DO BLDX^IBCEFG3
+5 SET VALMBCK="R"
+6 QUIT
+7 ;
FASTEXIT ; Sets a flag that system should be exited
+1 SET VALMBCK="Q"
+2 ;Ask this for all but the last level
IF $GET(VALMEVL)
Begin DoDot:1
+3 DO FULL^VALM1
+4 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Exit option entirely"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)!(Y)
SET IBFASTXT=1
End DoDot:1
+6 QUIT
+7 ;
DUPNM ;
+1 IF $DATA(^IBE(353,"B",X))
KILL X
WRITE !,*7,"A form with this name already exists"
+2 QUIT
+3 ;
DUPNUM ;
+1 IF $DATA(^IBE(353,X))
KILL X
WRITE !,*7,"A form with this number already exists"
+2 QUIT
