source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG4.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1IBCEFG4 ;ALB/TMP - OUTPUT FORMATTER MAINTENANCE - FORM ACTION PROCESSING ;22-JAN-96
2 ;;2.0;INTEGRATED BILLING;**52,51,320**;21-MAR-94
3 ;
4ADDL ; Add a new local form
5 N IBCT,IBDA,IBNAME,IBTYPE,IBBASE,IBNEW6,IBNEW7,IBOLD,IBOLD6,IBOLD7,LAST6,LAST7,DIR,X,Y,DD,DO,DIE,DR,DA,Z,Z0,Z1
6 D FULL^VALM1
7 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
8 G:$D(DIRUT) ADDLQ
9 S IBNAME=Y
10ADDL1 S DIR("A")="Enter form number (must be > 9999): ",DIR(0)="NA^9999:999999999^D @(""DUPNUM""_$C(94)_""IBCEFG4"")"
11 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
12 G:$D(DIRUT) ADDLQ
13 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
14 K DD,DO
15 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
16 S $P(^IBE(353,0),U,3)=$O(^IBE(353,9999),-1) L -^IBE(353,IBDA)
17 G:Y<0 ADDLQ
18 W !!,"WANT TO ASSOCIATE THIS FORM WITH A NATIONAL FORM" S %=2 D YN^DICN G:'(%+1#3) ADDL2
19 K % W !
20 S DIE="^IBE(353,",DR="2.05",DA=IBDA D ^DIE W !
21 I '$P($G(^IBE(353,IBDA,2)),U,5) W !,*7,"FORM NOT ASSOCIATED WITH ANY NATIONAL FORM"
22 G ADDLQ
23ADDL2 W !!,"WANT TO COPY ALL FIELDS FROM AN EXISTING FORM" S %=2 D YN^DICN G:'(%+1#3) ADDLQ
24 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
25 G:Y<0 ADDL2 S IBOLD=+Y
26 W !,"ARE YOU SURE YOU WANT TO MAKE THIS COPY" S %=2 D YN^DICN G:'(%+1#3) ADDLQ
27 W !!,"This may take a little while ... please be patient while I build your new form"
28 ;
29 ; IB*2*320
30 ; Make sure files 364.6 and 364.7 are set-up to add new entries in the
31 ; local number range (greater than 10000). We cannot allow these local
32 ; entries to get added into the national number range.
33 F Z=364.6,364.7 I $P($G(^IBA(Z,0)),U,3)<10000 D
34 . N IBLAST S IBLAST=$O(^IBA(Z," "),-1)
35 . I IBLAST<10000 S IBLAST=10000
36 . S $P(^IBA(Z,0),U,3)=IBLAST
37 . Q
38 ;
39 K ^TMP("IBX",$J)
40 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
41 ;
42 S LAST6=+$O(^DD(364.6,"GL",0,""),-1),LAST7=+$O(^DD(364.7,"GL",0,""),-1),IBCT=0
43 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
44 .S $P(^IBA(364.6,IBNEW6,0),U,4,LAST6)=$P(Z,U,4,LAST6)
45 .;
46 .I $D(^TMP("IBX",$J,2,IBOLD6)) S Z0=^(IBOLD6) D ;parent record
47 ..I '$D(^TMP("IBX",$J,1,+Z0,1)) S ^TMP("IBX",$J,2,IBOLD6,1)=IBNEW6 Q
48 ..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
49 .I $P(Z,U,3) D ;child record
50 ..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
51 ..S ^TMP("IBX",$J,1,IBOLD6,1)=IBNEW6
52 .;
53 .S DA=IBNEW6,DIK="^IBA(364.6," D IX1^DIK
54 .S IBOLD7=$O(^IBA(364.7,"B",IBOLD6,"")) Q:'IBOLD7
55 .S IBNEW7=$$NEW(7,IBNEW6) Q:'IBNEW7
56 .S $P(^IBA(364.7,IBNEW7,0),U,3,LAST7)=$P(^IBA(364.7,IBOLD7,0),U,3,LAST7)
57 .I $G(^IBA(364.7,IBOLD7,1))'="" S ^IBA(364.7,IBNEW7,1)=^IBA(364.7,IBOLD7,1)
58 .S DA=IBNEW7,DIK="^IBA(364.7," D IX1^DIK
59 K ^TMP("IBX",$J)
60 W !!,"Field copy completed - ",IBCT," fields copied",!!
61ADDLQ I $G(IBDA) D EDITL(IBDA),BLD^IBCEFG3
62 S VALMBCK="R"
63 Q
64 ;
65NEW(FILE,KEY) ; Add a new local entry to file 364.FILE whose .01 field is KEY
66 ; RETURN IEN OF NEW ENTRY OR 0 IF NONE ADDED
67 K DO,DD
68 S DLAYGO=364_"."_FILE,DIC="^IBA(364."_FILE_",",DIC("DR")=".02////L",X=KEY,DIC(0)="L"
69 D FILE^DICN K DIC,DD,DO,DLAYGO
70 W "."
71 Q $S(Y>0:+Y,1:0)
72 ;
73EDIT ; Edit a local form
74 D FULL^VALM1
75 D:$G(IBCEXDA) EDITL(IBCEXDA),BLDX^IBCEFG3
76 S VALMBCK=$S($D(^IBE(353,+$G(IBCEXDA))):"R",1:"Q")
77 Q
78 ;
79EDITL(DA) ; Edit a local form whose entry number is DA
80 S DIE="^IBE(353,",DR="[IBCE ADD/EDIT LOCAL FORM]" D ^DIE
81 Q
82 ;
83FFLDS ; Edit Local Form Fields
84 D FULL^VALM1
85 D EN^VALM("IBCE FORM FIELDS LIST")
86 S VALMBCK="R"
87 Q
88 ;
89CHGFORM ; Select a new form without going back a screen
90 N DIC,DA
91 D FULL^VALM1
92 S DIC="^IBE(353,",DIC("S")="I $P($G(^(2)),U,4)=0",DIC(0)="AEMQ" D ^DIC
93 I Y>0 S IBCEXDA=+Y D HDRX^IBCEFG3,BLDX^IBCEFG3
94 S VALMBCK="R"
95 Q
96 ;
97FASTEXIT ; Sets a flag that system should be exited
98 S VALMBCK="Q"
99 I $G(VALMEVL) D ;Ask this for all but the last level
100 .D FULL^VALM1
101 .K DIR S DIR(0)="Y",DIR("A")="Exit option entirely",DIR("B")="NO" D ^DIR K DIR
102 .I $D(DIRUT)!(Y) S IBFASTXT=1
103 Q
104 ;
105DUPNM ;
106 I $D(^IBE(353,"B",X)) K X W !,*7,"A form with this name already exists"
107 Q
108 ;
109DUPNUM ;
110 I $D(^IBE(353,X)) K X W !,*7,"A form with this number already exists"
111 Q
Note: See TracBrowser for help on using the repository browser.