source: FOIAVistA/tag/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSRVS.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1GMRCSRVS ;SLC/DCM,JFR - Add/Edit services in File 123.5. ;6/14/00 12:00
2 ;;3.0;CONSULT/REQUEST TRACKING;**1,16,40,53**;DEC 27, 1997;Build 3
3 ;
4EN ;set up services entry point
5 ;GMRCOLDU=Service Usage field. If changed, GMRCOLDU shows the change (See ^DD(123.5,2,0) for field description).
6 N GMRCSAFE,GMRCOLDU,GMRCOLDS,GMRCOSNM,GMRCSRVC,GMRCACT,GMRCSSNM
7 N DIC,DLAYGO,DUOUT,DTOUT
8 S DIC="^GMR(123.5,",DLAYGO=123.5,DIC(0)="AELMQZ",DIC("A")="Select Service/Specialty:"
9 D ^DIC I $S(Y<0:1,$D(DTOUT):1,$D(DUOUT):1,1:0) D END K GMRCMSG,DTOUT,DUOUT Q
10 D
11 .S GMRCSAFE=+$G(^GMR(123.5,+Y,"INT"))
12 .S (DA,GMRCSRVC)=+Y,GMRCOSNM=$P(Y,"^",2),(GMRCOLDU,GMRCOLDS)=""
13 .S GMRCACT=$S('$O(^GMR(123.5,+Y,0)):"MAD",1:"MUP"),GMRCOLDU=$P(^(0),"^",2),GMRCOLDN=$P(^(0),"^",1) S ND=0,GMRCOLDS="" F S ND=$O(^GMR(123.5,+Y,2,ND)) Q:ND?1A.E!(ND="") S GMRCOLDS=GMRCOLDS_^GMR(123.5,+Y,2,ND,0)_"^"
14 .S DIE=DIC,DR="[GMRC SETUP REQUEST SERVICE]",DIE("NO^")="OUTOK"
15 .D ^DIE
16 .Q
17 S GMRCACT=$S($P(^GMR(123.5,GMRCSRVC,0),"^",2)=9:"MDC",$P(^(0),"^",2)=1:"MDC",1:GMRCACT) D
18 .S GMRCSSNM=$P(^GMR(123.5,GMRCSRVC,0),"^",1)
19 .I GMRCACT'="MAD",GMRCSSNM'=GMRCOSNM S GMRCACT="MUP"
20 .I $S(GMRCACT'="MAD":1,GMRCACT'="MUP":1,1:0),$L(GMRCOLDU),GMRCOLDU=$P(^GMR(123.5,GMRCSRVC,0),"^",2) S GMRCACT="NOACT"
21 .I $S(GMRCACT="MUP":1,GMRCACT="NOACT":1,1:0),GMRCOLDN'=$P(^GMR(123.5,GMRCSRVC,0),"^",1) S GMRCACT="MUP"
22 .S ND=0 F S ND=$O(^GMR(123.5,GMRCSRVC,2,ND)) Q:ND?1A.E!(ND="") I GMRCOLDS'=""&(^GMR(123.5,GMRCSRVC,2,ND,0)'=""),GMRCOLDS'[^GMR(123.5,GMRCSRVC,2,ND,0) S GMRCACT="MUP" Q
23 .I $S(GMRCACT="MAD":1,GMRCACT="MUP":1,GMRCACT="MDC":1,1:0) D SVC^GMRC101H(GMRCSRVC,GMRCSSNM,GMRCACT),MSG^XQOR("GMRC ORDERABLE ITEM UPDATE",.GMRCMSG)
24 .D PTRCLN^GMRCU
25 .Q
26 K GMRCMSG,GMRCSSNM,GMRCSRVS,GMRCOLDN,GMRCOLDS,GMRCOLDU,ND
27 ;Ask to continue...
28 ;
29 N GMRC0,GMRCA,GMRCB,GMRCH,GMRCL
30 S GMRC0="YA",GMRCA="Add/Edit Another Service? ",GMRCB="NO"
31 S GMRCH="Enter 'YES' to add/edit another service, or 'NO' to exit."
32 S GMRCL=2
33 I '+$$READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL) D END Q
34 G EN
35 ;
36END K DIC,DIE,DTOUT,DUOUT,DA,DR,FL,GMRCACT,GMRCANS,GMRCMSG,GMRCREA,GMRCSRVC,GMRCSSNM,REVCODE,RLEVCODE,Y
37 Q
38 ;
39READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL,GMRCS) ;
40 ;
41 ; GMRC0 -> DIR(0) --- Type of read
42 ; GMRCA -> DIR("A") - Prompt
43 ; GMRCB -> DIR("B") - Default Answer
44 ; GMRCH -> DIR("?") - Help text or ^Execute code
45 ; GMRCS -> DIR("S") - Screen
46 ; GMRCL -> Number of blank lines to put before Prompt
47 ;
48 ; Returns "^" or answer
49 ;
50 N GMRCLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
51 Q:'$L($G(GMRC0)) U
52 S DIR(0)=GMRC0
53 S:$L($G(GMRCA)) DIR("A")=GMRCA
54 I $D(GMRCA("A")) M DIR("A")=GMRCA("A")
55 S:$L($G(GMRCB)) DIR("B")=GMRCB
56 I $D(GMRCH("?")) M DIR("?")=GMRCH("?")
57 S:$L($G(GMRCH)) DIR("?")=GMRCH
58 S:$L($G(GMRCS)) DIR("S")=GMRCS
59 F GMRCLINE=1:1:($G(GMRCL)-1) W !
60 D ^DIR
61 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
62 Q Y
63 ;
64NOED(SERV) ;
65 I '$D(^GMR(123.5,+SERV,0)) Q 0
66 N NAME
67 S NAME=$P(^GMR(123.5,+SERV,0),U)
68 I NAME="PROSTHETICS REQUEST" Q 1
69 I NAME="EYEGLASS REQUEST" Q 1
70 I NAME="CONTACT LENS REQUEST" Q 1
71 I NAME="HOME OXYGEN REQUEST" Q 1
72 Q 0
73 ;
74CLONPSAS ; clone a PROSTHETICS service
75 ; choose service and text to append
76 N GMRCSIEN,GMRCROOT,GMRCNWNM
77 N GMRCCPY,GMRCNEW,FDA,GMRCERR,GMRC
78 S GMRC(0)="PAO^GMR(123.5,:AEMQ"
79 S GMRC("A")="Select the Prosthetics Service to clone: "
80 S GMRC("S")="I $$NOED^GMRCSRVS(+Y)"
81 S GMRCCPY=+$$READ(GMRC(0),GMRC("A"),,,2,GMRC("S"))
82 I 'GMRCCPY Q
83 K GMRC
84 S GMRCNWNM=$$GETAPP(GMRCCPY)
85 I '$L(GMRCNWNM) Q
86 S FDA(1,123.5,"+1,",.01)=GMRCNWNM
87 S FDA(1,123.5,"+1,",2)="DISABLED"
88 S FDA(1,123.5,"+1,",1.01)="REQUIRE"
89 S FDA(1,123.5,"+1,",1.02)="LEXICON"
90 S FDA(1,123.5,"+1,",123.01)="CONSULTS"
91 S FDA(1,123.5,"+1,",123.03)="GMRCACTM SERVICE ACTION MENU"
92 S FDA(1,123.5,"+1,",131)="YES"
93 D UPDATE^DIE("E","FDA(1)","GMRCNEW","GMRCERR")
94 I '$D(GMRCNEW) W !,"Failed to create new entry. Please try again" Q
95 W !!,GMRCNWNM," created",!
96 S GMRCSIEN=GMRCNEW(1)_","
97 S GMRCROOT="^GMR(123.5,"_GMRCCPY_",124)"
98 D WP^DIE(123.5,GMRCSIEN,124,,GMRCROOT,"GMRCERR")
99 W !!,"The new Service is currently DISABLED. To activate this service for use in"
100 W !,"the Prosthetics interface, you MUST use the Setup Consult Services option"
101 W !,"and delete the DISABLED flag from the SERVICE USAGE field.",!
102 Q
103GETAPP(GMRIEN) ;get text to append
104 N GMRCNWNM,QTFLG,I,GMRC,GMRCHL,OK
105 S GMRCNWNM=""
106 F I=0:0 D Q:$G(QTFLG)
107 . W !!
108 . S GMRC(0)="FA^3:40"
109 . S GMRC("A")="Enter text to append to national service name: "
110 . S GMRCHL("?",1)="The text entered will be appended to the name of the exported service"
111 . S GMRCHL("?")="(e.g. If HINES was entered it may appear as PROSTHETICS REQUEST - HINES"
112 . S GMRCNWNM=$$READ(GMRC(0),GMRC("A"),,.GMRCHL,2)
113 . I '$L(GMRCNWNM)!(GMRCNWNM["^") S GMRCNWNM="",QTFLG=1 Q
114 . K GMRC,GMRCHL
115 . S GMRCNWNM=$P(^GMR(123.5,GMRIEN,0),U)_" - "_GMRCNWNM
116 . I $$FIND1^DIC(123.5,,"X",GMRCNWNM) D Q
117 .. W !!,$C(7),"This service already exists, you'll have to try again!",!
118 .. S GMRCNWNM=""
119 . W !,"The new service name will be:"
120 . W !,?5,GMRCNWNM,!
121 . S OK=+$$READ("Y","Is this OK",,,1)
122 . I OK=U S QTFLG=1 Q
123 . I 'OK S GMRCNWNM="" Q
124 . S QTFLG=1
125 Q GMRCNWNM
126INPUT(X,GMRCDA) ; INPUT TRANSFORM FOR THE SUB-SERVICE/SPECIALTY (#.01) FIELD
127 ; OF THE SUB-SERVICE (#123.51) FILE WHICH IS A SUB-FILE OF THE
128 ; SUB-SERVICE (#10) FIELD OF THE REQUEST SERVICES (#123.5) FILE.
129 ;
130 ; X = INTERNAL VALUE OF USER SELECTED SUB-SERVICE (IEN OF SERVICE
131 ; IN FILE 123.5)
132 ; GMRCDA = IEN OF INITIAL PARENT SERVICE IN FILE 123.5
133 ;
134 I +$G(X)=0 K X Q
135 I GMRCDA<1 D Q:'$D(X)
136 . S GMRCDA=+$G(D0)
137 . I GMRCDA<1 K X
138 N GMRPARNT,GMRCHILD,GMRQ,GMRCNT
139 K ^TMP("GMRC INPUT",$J) ;MAKE SURE INPUT PARENT LOG GLOBAL IS BLANK
140 I X=GMRCDA S GMRQ=1 G INPUTQ ;NOT ALLOW SERVICE AS A SUB-SERVICE TO ITSELF
141 S ^TMP("GMRC INPUT",$J,"B",GMRCDA)="" ;USED TO PREVENT DUPLICATE CHECKING OF PARENTS
142 S ^TMP("GMRC INPUT",$J,0)=1 ;USED TO FIND NEXT NUMBER FOR TMP GLOBAL ENTRY
143 S ^TMP("GMRC INPUT",$J,1)=GMRCDA ;PARENT IEN STORED TO BE USED AS CHILD
144 S (GMRCNT,GMRQ)=0
145 F S GMRCNT=$O(^TMP("GMRC INPUT",$J,GMRCNT)) Q:'GMRCNT D Q:GMRQ=1
146 . S GMRCHILD=$G(^TMP("GMRC INPUT",$J,GMRCNT))
147 . S GMRPARNT=0
148 . F S GMRPARNT=$O(^GMR(123.5,"APC",GMRCHILD,GMRPARNT)) Q:GMRPARNT="" D Q:GMRQ=1
149 .. I GMRPARNT=X S GMRQ=1 Q ;NOT ALLOW SERVICE AS A SUB-SERVICE WITHIN IT'S SUB-SERVICE HIERARCHY
150 .. I '$D(^TMP("GMRC INPUT",$J,"B",GMRPARNT)) D ;IF NOT IN LIST ADD
151 ... S ^TMP("GMRC INPUT",$J,"B",GMRPARNT)="" ;ADD TO "B" CROSS-REFERENCE
152 ... S ^TMP("GMRC INPUT",$J,0)=$G(^TMP("GMRC INPUT",$J,0))+1 ;INCREASE LAST NUMBER BY 1
153 ... S ^TMP("GMRC INPUT",$J,$G(^TMP("GMRC INPUT",$J,0)))=GMRPARNT ;ADD NEW PARENT SERVICE TO GLOBAL SO IT CAN BE CHECKED AS A CHILD ENTRY TO FIND IT'S PARENTS
154 K ^TMP("GMRC INPUT",$J)
155INPUTQ I GMRQ=1 D EN^DDIOL("A SERVICE CAN NOT BE A SUB-SERVICE OF ITSELF","","!!?12") K X Q
156 ;
157DUPCHK ;CHECK FOR CONSULT SERVICES APPEARING AS PART OF THE CONSULT SERVICE
158 ;HIERARCHY IN MORE THAN ONE PLACE
159 N ARRAY,COUNT,GMRCON,PARENT
160 S PARENT=0
161 ;Check if they are a sub-service to more than one service.
162 F COUNT=0:1 S PARENT=$O(^GMR(123.5,"APC",X,PARENT)) Q:'+PARENT
163 ;Print message about which services this service is a sub-service of.
164 I COUNT'>0 Q
165 S COUNT=1
166 S ARRAY(COUNT)=" ",COUNT=COUNT+1
167 S ARRAY(COUNT)=" ",COUNT=COUNT+1
168 S ARRAY="Service "_$P(^GMR(123.5,X,0),"^",1)_" is already a sub-service of:"
169 D PARSE(.ARRAY)
170 S PARENT=0
171 F S PARENT=$O(^GMR(123.5,"APC",X,PARENT)) Q:'+PARENT S ARRAY=" "_$P(^GMR(123.5,PARENT,0),"^",1) D PARSE(.ARRAY)
172 S ARRAY(COUNT)=" ",COUNT=COUNT+1
173 S ARRAY(COUNT)="A consult service appearing as part of the Consult service",COUNT=COUNT+1
174 S ARRAY(COUNT)="hierarchy in more than one place (i.e. a sub-service of more",COUNT=COUNT+1
175 S ARRAY(COUNT)="than one parent) has the potential to skew the results of the",COUNT=COUNT+1
176 S ARRAY(COUNT)="Consult Performance Monitor Report [GMRC RPT PERF MONITOR].",COUNT=COUNT+1
177 S ARRAY(COUNT)=" ",COUNT=COUNT+1
178 D EN^DDIOL(.ARRAY)
179 I '$G(DIQUIET) D
180 . S GMRCON=0
181 . D YESNO(X,Y)
182 . I 'GMRCON K X
183 . D EN^DDIOL(" ")
184 Q
185PARSE(ARRAY) ;TAKE ARRAY VALUE AND PARSE INTO PIECES SHORTER THAN 70 CHARACTERS
186 N ARRAYSP,GMRCNT
187PARSE1 I $L(ARRAY)'>70 S ARRAY(COUNT)=ARRAY,COUNT=COUNT+1 Q
188 F GMRCNT=70:-1 S ARRAYSP=$E(ARRAY,GMRCNT) I ARRAYSP=" " Q
189 S ARRAY(COUNT)=$E(ARRAY,1,GMRCNT-1),COUNT=COUNT+1
190 S ARRAY=$E(ARRAY,GMRCNT+1,9999)
191 G:ARRAY'="" PARSE1
192 Q
193YESNO(X,Y) ;YES/NO QUESTION/RESPONSE
194 N DIR,DIROUT,DIRUT,DTOUT,DUOUT
195 S DIR(0)="YA"
196 S DIR("A")="Do you wish to continue adding "_$P(^GMR(123.5,X,0),"^",1)_" as a new sub-service? "
197 S DIR("B")="NO"
198 S DIR("T")=300
199 S DIR("?",1)="Enter ""YES"" to add service as a sub-service."
200 S DIR("?")="Enter ""NO"" to NOT add the service as a sub-service."
201 D ^DIR Q:($G(DTOUT))!($G(DUOUT))!($G(DIROUT))
202 I Y=1 S GMRCON=1
203 Q
Note: See TracBrowser for help on using the repository browser.