source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFUTL2.m@ 1036

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

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1IBDFUTL2 ;ALB/MAF - MAINTENANCE UTILITY CONT. - 4/24/95
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**9**;APR 24, 1997
3 ;
4 ;
5ENDV ; -- Entire divisions were choosen, find all clinics (with encounter forms defined)
6 N IBCLN,IBDIV,NODE,DIVISION,ALL
7 ; -- Make a list of the divisions chosen
8 S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("IBDF",$J,"D",IBDFGNM)) Q:IBDFGNM']"" S IBDIV=0 F S IBDIV=$O(^TMP("IBDF",$J,"D",IBDFGNM,IBDIV)) Q:'IBDIV S DIVISION(IBDIV,IBDFGNM)=""
9 ;
10 ; -- Loop through all the clinics finding ones in selected divisions
11 S IBCLN="" F S IBCLN=$O(^SC(IBCLN)) Q:IBCLN="" D
12 .S NODE=$G(^SC(IBCLN,0))
13 .S IBDIV=$P(NODE,"^",15)
14 .I IBDIV Q:'$D(DIVISION(IBDIV))
15 .; -- Check that location is a clinic
16 .Q:$P(NODE,"^",3)'="C"
17 .; -- It passed all the tests, put it on the list
18 .S IBDNAM=0 F IBDFDIV=0:0 S IBDFDIV=$O(DIVISION(IBDFDIV)) Q:'IBDFDIV I IBDFDIV=IBDIV F IBDNAME=0:0 S IBDNAM=$O(DIVISION(IBDFDIV,IBDNAM)) Q:IBDNAM']"" S ^TMP("IBDF",$J,"C",IBDNAM,$P(^SC(IBCLN,0),"^",1))=IBCLN
19 ;
20 ; -- Don't need list of divisions anymore
21 K ^TMP("IBDF",$J,"D")
22 Q
23 ;
24 ;
25CLINICS ; -- Clinics that use the form
26 N IBDFFLG
27 S IBDFFLG=0 F IDX="C","D","E","F","G","H","I","J" D
28 .S SETUP="" F S SETUP=$O(^SD(409.95,IDX,IBDFORM1,SETUP)) Q:'SETUP D
29 ..S CLINIC=$P($G(^SD(409.95,SETUP,0)),"^",1)
30 ..Q:'CLINIC
31 ..S NAME=$P($G(^SC(CLINIC,0)),"^",1)
32 ..Q:NAME=""
33 ..I IBDFFLG S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
34 ..D:'IBDFFLG TMP1 S:IBDFFLG X="" S X=$$SETSTR^VALM1($E(NAME,1,20),X,66,14) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,37,29,IOINHI,IOINORM,0) S IBDFFLG=1
35 Q
36 ;
37 ;
38TMP1 ; -- Text display set up of TMP array
39 S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
40 S X=$$SETSTR^VALM1(" ",X,1,80) D TMP^IBDFUTL1
41 S X="",X=$$SETSTR^VALM1("CLINICS USING THIS FORM ARE: ",X,37,29)
42 Q
43 ;
44 ;
45HEADER ; -- Set up header line for the display
46 I VALMCNT>0 N IBXFL S IBXFL=$S(VALMCNT+1/14?1.6N:1,VALMCNT+2/14?1.6N:2,VALMCNT+3/14?1.6N:3,VALMCNT+4/14?1.6N:4,1:0) I IBXFL D
47 .N IBXFL1
48 .F IBXFL1=1:1:IBXFL D
49 ..S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
50 S IBDCNT1=IBDCNT1+1
51 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
52 S X=""
53 S IBDF(IBDFNAME)=IBDCNT_"^"_IBDFORM1
54 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
55 S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
56 S IBDVAL=IBDFNAME
57 S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
58 S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
59 S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
60 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
61 S IBDCNT1=IBDCNT1-1
62 Q
63 ;
64 ;
65JUMP ; -- Jump action to display a specific clinic group on the screen.
66 D FULL^VALM1
67 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=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="QEZ" D ^DIC K DIC G:Y<0 JMP S Y=+Y D JUMP1 Q
68JMP S DIC=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="AEMN",DIC("A")="Select "_$S($D(VAUTF):"Form",$D(VAUTG):"Clinic Group",1:"Clinic")_" you wish to move to: "
69 S:$D(VAUTC) DIC("S")="I $P(^SC(+Y,0),U,3)=""C""" D ^DIC K DIC
70 I X["^" S VALMBG=1,VALMBCK="R" Q
71 ;
72 ;
73JUMP1 I Y<0 G JUMP
74 N IBDFCAT
75 S IBDFCAT=$S($D(VAUTF):$P(^IBE(357,+Y,0),"^",1),$D(VAUTG):$P(^IBD(357.99,+Y,0),"^",1),1:$P(^SC(+Y,0),"^",1))
76 I '$D(IBDF(IBDFCAT)) W !!,"There is no data listed for this Clinic Group" G JMP
77 S VALMBG=+IBDF(IBDFCAT) S VALMBCK="R" Q
78 Q
79 ;
80 ;
81JSEL ; -- Convert number selected to name
82 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)
83 Q
84 ;
85 ;
86CHGLST ; -- Code to change list display
87 D FULL^VALM1
88 S IBDFDIS1=IBDFDIS,IBDFINT1=IBDFINT,IBDFACT1=IBDFACT
89 D EXIT1^IBDFUTL,OUT^IBDFUTL
90 Q
91 ;
92 ;
93DELETE ; -- Delete invalid code from the selection list/block
94 N IBDFVALM,VALMY,IBBLK,IBFORM,DA
95 S VALMBCK=""
96 D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDFVALM=0
97 D FULL^VALM1 S VALMBCK="R"
98 F IBDFVALM=0:0 S IBDFVALM=$O(VALMY(IBDFVALM)) Q:IBDFVALM']"" S DA=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",4) I DA]"" S IBFORM=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",5),IBBLK=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",6) D
99 .S DIK="^IBE(357.3,",DA=DA D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
100 K IBDF,^TMP("UTIL",$J)
101 ;
102 ; -- Redo list
103REP K IBDF D INIT^IBDFUTL S VALMBG=1,VALMBCK="R"
104 Q
Note: See TracBrowser for help on using the repository browser.