source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFCG.m@ 1499

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

initial load of FOIAVistA 6/30/08 version

File size: 5.9 KB
Line 
1IBDFCG ;MAF/ALB - CLINIC GROUP FORMS SCREEN ; 09-FEB-1995
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4 ;
5EN ; -- main entry point for IBDF EF CLINIC GROUP LT
6 D EN^VALM("IBDF EF CLINIC GROUP LT")
7 Q
8 ;
9 ;
10HDR ; -- header code
11 S VALMHDR(1)="This is a list of the Clinic Groups and the Clinics"
12 S VALMHDR(2)="and Divisions under them."
13 Q
14 ;
15 ;
16INIT ; -- init variables and list array
17 N IBDFNODE,IBDFCL,IBDIFN,IBDFCGNM,IBDFCNUM,IBDCNT,IBDCNT1,IBDVAL,IBDVAL1,IBDFVAL,IBFASTXT,IBDCG,IBDCL,IBDDV,IBDFCFLG,IBDFCIEN,IBDFCN,IBDFDFLG,IBDFDIEN,IBDFGN,IBDFX,IBDVALM
18 K IBDCLN1,IBDFCG
19 S (IBDCNT,IBFASTXT,IBDCNT1,VALMCNT)=0
20 K ^TMP("IBMF",$J),^TMP("IBDFCG",$J),^TMP("CGIDX",$J),IBDCLN D KILL^VALM10()
21 S (IBDFGN,IBDFCGNM)=0
22 F IBDFGN=0:0 S IBDFCGNM=$O(^IBD(357.99,"B",IBDFCGNM)) Q:IBDFCGNM']"" F IBDIFN=0:0 S IBDIFN=$O(^IBD(357.99,"B",IBDFCGNM,IBDIFN)) Q:IBDIFN'>0 I IBDIFN]"" D ARRAY
23 S (IBDFCG,IBDFCGNM)=0
24 F IBDFCN=0:0 S IBDFCGNM=$O(IBDCLN1(IBDFCGNM)) Q:IBDFCGNM']"" F IBDCG=0:0 S IBDCG=$O(IBDCLN1(IBDFCGNM,IBDCG)) Q:'IBDCG I $D(IBDCLN1(IBDFCGNM,IBDCG)) S IBDCNT1=IBDCNT1+1 D GROUPS D
25 .F IBDFX=IBDFX:0 S IBDFX=$O(^TMP("IBMF",$J,IBDCG,IBDFX)) Q:'IBDFX D SETG1
26 .I $O(IBDCLN1(IBDFCGNM))]"" S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1 S X="",X=$$SETSTR^VALM1(X,X,1,80) D TMP
27 ;
28 I '$D(^TMP("IBDFCG",$J)) D NUL
29 Q
30 ;
31 ;
32ARRAY ; -- Setting up array for clinic groups and the divisions and clinics
33 S IBDCLN1(IBDFCGNM,IBDIFN)=IBDIFN
34 S (IBDDV,IBDCL)=0 D CLIN^IBDFCG1 D DIV^IBDFCG1
35 S (IBDFX,IBDDV,IBDCL,IBDFCFLG,IBDFDFLG,IBDFCIEN,IBDFDIEN)=0
36 F IBDFX=0:0 S IBDFX=IBDFX+1 D:'IBDFCFLG CLIN1^IBDFCG1 D:'IBDFDFLG DIV1^IBDFCG1 Q:IBDFCFLG=1&(IBDFDFLG=1)
37 Q
38 ;
39 ;
40SETG1 ; -- Creating the list entries
41 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
42 S X=""
43 S IBDFVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"D",0))
44 S IBDFVAL=$G(^TMP("IBMF",$J,IBDCG,IBDFX,"D",+IBDFVAL)) S X=$$SETSTR^VALM1(IBDFVAL,X,28,26)
45 S IBDFVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0))
46 S IBDFVAL=$G(^TMP("IBMF",$J,IBDCG,IBDFX,"C",+IBDFVAL)) S X=$$SETSTR^VALM1(IBDFVAL,X,56,23)
47 D TMP
48 Q
49 ;
50 ;
51GROUPS ; -- Creating the Listman Clinic Name titles for the list
52 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
53 S IBDFCG(IBDFCGNM)=IBDCNT_"^"_IBDCG
54 S X="",X=$$SETSTR^VALM1(IBDCNT1_" "_IBDFCGNM,X,1,26)
55 S IBDFX=1
56 I '$O(^TMP("IBMF",$J,IBDCG,IBDFX,"D",0)),'$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0)) D TMP,CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0) Q
57 S IBDVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"D",0)) I IBDVAL S IBDVAL=^TMP("IBMF",$J,IBDCG,IBDFX,"D",IBDVAL) S X=$$SETSTR^VALM1(IBDVAL,X,28,26) I '$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0)) D TMP,CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0)
58 S IBDVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0)) I IBDVAL S IBDVAL=^TMP("IBMF",$J,IBDCG,IBDFX,"C",IBDVAL) S X=$$SETSTR^VALM1(IBDVAL,X,56,24) D TMP,CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0)
59 Q
60 ;
61 ;
62TMP S ^TMP("IBDFCG",$J,IBDCNT,0)=X,^TMP("IBDFCG",$J,"IDX",VALMCNT,IBDCNT1)=""
63 S ^TMP("CGIDX",$J,IBDCNT1)=VALMCNT_"^"_IBDCG
64 Q
65 ;
66 ;
67EDIT ; -- Edit a selected Clinic Group
68 N IBDVALM,VALMY
69 S VALMBCK=""
70 D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDVALM=0
71 D FULL^VALM1 S VALMBCK="R"
72 F IBDVALM=0:0 S IBDVALM=$O(VALMY(IBDVALM)) Q:'IBDVALM S DA=^TMP("CGIDX",$J,IBDVALM),DA=$P(DA,"^",2) D
73 .D MESS
74 .W !!,"Clinic Group: "_$P($G(^IBD(357.99,DA,0)),"^",1)
75 .S DIE="^IBD(357.99,",DA=DA,DR=".01;I $O(^IBD(357.99,DA,11,0)) S Y=""@99"";10;@99;I $O(^IBD(357.99,DA,10,0)) S Y=""@999"";11;@999" D ^DIE K DA,DIE,DR
76 D REP1 Q
77 ;
78DEL ; -- Delete Clinic Group
79 N IBDVALM,VALMY,DIR,DIRUT,DUOUT
80 S VALMBCK=""
81 D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDVALM=0
82 D FULL^VALM1 S VALMBCK="R"
83 F IBDVALM=0:0 S IBDVALM=$O(VALMY(IBDVALM)) Q:'IBDVALM S DA=^TMP("CGIDX",$J,IBDVALM),DA=$P(DA,"^",2) D
84 .I $O(^IBD(357.09,"ACG",DA,0)) W !!,"In use by parameter group, Not deleted",! D PAUSE^VALM1 Q
85 .W !!,"Clinic Group: "_$P($G(^IBD(357.99,DA,0)),"^",1)
86 .W ! S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are You Sure you want to delete "_$P($G(^IBD(357.99,DA,0)),"^",1)
87 .D ^DIR K DIR I Y'=1 W !,"Entry ",$P($G(^IBD(357.99,DA,0)),"^",1)," not Deleted!" Q
88 .D DP1
89 ;
90DELQ D INIT
91 S VALMBCK="R" Q
92 ;
93DP1 ; -- actual deletion
94 S DIK="^IBD(357.99," D ^DIK
95 W !,"Entry ",IBDVALM," Deleted"
96 Q
97 ;
98QE ; -- Quick edit Review entry
99 Q
100 ;
101MESS ; -- Message prior to editing a group
102 W !!,"Enter the clinics for this clinic group. Enter as many Clinics as you want."
103 W !,"If you want all clinics for a division, do not enter any clinics but enter"
104 W !,"the division name at the Select Division: prompt."
105 Q
106 ;
107ADD1 ; -- Add/Edit Clinic Group
108 N DLAYGO
109 D FULL^VALM1
110 D MESS
111 W ! S DIC("A")="Select GROUP NAME: ",DIC="^IBD(357.99,",DIC(0)="AELQMN",DIC("DR")=".01",DLAYGO=357.99 D ^DIC K DIC G:Y<1 REP1 S DA=+Y
112 S DIE="^IBD(357.99,",DA=DA,DR="I $O(^IBD(357.99,DA,11,0)) S Y=""@99"";10;I $O(^IBD(357.99,DA,10,0)) S Y=""@999"";11;@999" D ^DIE K DA,DIE,DR G ADD1
113 ;
114 ;
115REP D INIT^IBDFPE S VALMBCK="R" Q
116 ;
117 ;
118REP1 D INIT^IBDFCG S VALMBCK="R" Q
119 ;
120 ;
121JUMP ; -- Jump action to display a specific clinic group on the screen.
122 D FULL^VALM1
123 I $D(XQORNOD(0)),$P(XQORNOD(0),"^",4)]"" S X=$P(XQORNOD(0),"^",4) S X=$P(X,"=",2) I X]"" D:X?1.6N JSEL S DIC="^IBD(357.99,",DIC(0)="QEZ" D ^DIC K DIC G:Y<0 JMP S Y=+Y D JUMP1 Q
124JMP S DIC="^IBD(357.99,",DIC(0)="AEMN",DIC("A")="Select Clinic Group you wish to move to: " D ^DIC K DIC
125 I X["^" S VALMBG=1,VALMBCK="R" Q
126JUMP1 I Y<0 G JUMP
127 N IBDFCAT
128 S IBDFCAT=$P(^IBD(357.99,+Y,0),"^",1)
129 I '$D(IBDFCG(IBDFCAT)) W !!,"There is no data listed for this Clinic Group" G JMP
130 S VALMBG=+IBDFCG(IBDFCAT) S VALMBCK="R" Q
131 Q
132 ;
133 ;
134JSEL ; -- Convert number selected to name
135 S IBDVALM=X I $D(^TMP("CGIDX",$J,IBDVALM)) S X=$P(^TMP("CGIDX",$J,IBDVALM),"^",2),X=$P(^IBD(357.99,X,0),"^",1)
136 Q
137 ;
138 ;
139HELP ; -- help code
140 S X="?" D DISP^XQORM1 W !!
141 Q
142 ;
143 ;
144EXIT ; -- exit code
145 K IBDCLN,IBDCLN1,IBDFCG
146 K ^TMP("IBMF",$J)
147 Q
148 ;
149EXPND ; -- expand code
150 Q
151 ;
152NUL ; -- NULL MESSAGE
153 S ^TMP("IBDFCG",$J,1,0)=" ",^TMP("IBDFCG",$J,2,0)="There are no CLINIC GROUPS listed.",^TMP("CGIDX",$J,1)=1,^TMP("CGIDX",$J,2)=2
154 Q
Note: See TracBrowser for help on using the repository browser.