source: WorldVistAEHR/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCDRFR.m@ 1141

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1GMRCDRFR ;SLC/JFR - DEFAULT REASON FOR REQUEST UTILS ; 11/12/00 12:00
2 ;;3.0;CONSULT/REQUEST TRACKING;**12,15**;DEC 27, 1997
3 ;
4 ; This routine invokes IA #2876
5 ;
6EN ; -- main entry point for GMRC DEFAULT REASON
7 N GMRCSV,GMRCDFN,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
8 S DIR(0)="SOA^S:service;P:procedure"
9 S DIR("A")="Test default for service or procedure? "
10 D ^DIR I $D(DIRUT) Q
11 I Y="S" D SELSS Q:'$D(GMRCSV)
12 I Y="P" D SELPROC Q:'$D(GMRCPROC)
13 D SELPT Q:'$D(GMRCPAT)
14 D INIT
15 D EN^VALM("GMRC DEFAULT REASON")
16 Q
17 ;
18SELPT ;get new patient
19 N DIR,X,Y,DIRUT,DUOUT,DTOUT
20 D FULL^VALM1
21 S DIR(0)="PO^2:EQM" D ^DIR
22 I $D(DIRUT) Q
23 S GMRCPAT=+Y
24 K ^TMP("GMRCRFR",$J)
25 Q
26 ;
27SELSS ; get new service
28 N DIR,X,Y,DIRUT,DUOUT,DTOUT
29 D FULL^VALM1
30 K GMRCSV,GMRCPROC
31 S DIR(0)="PO^123.5:EMQ",DIR("A")="Select Service"
32 D ^DIR
33 I $D(DIRUT) Q
34 S GMRCSV=+Y_";99CON"
35 K ^TMP("GMRCRFR",$J)
36 Q
37 ;
38SELPROC ; get a new procedure
39 ;
40 N DIR,X,Y,DIRUT,DUOUT,DTOUT
41 D FULL^VALM1
42 K GMRCSV,GMRCPROC
43 S DIR(0)="PO^123.3:EMQ",DIR("A")="Select Procedure"
44 D ^DIR
45 I $D(DIRUT) Q
46 S GMRCPROC=+Y_";99PRC"
47 K ^TMP("GMRCRFR",$J)
48 Q
49 ;
50HDR ; -- header code
51 I $D(GMRCPROC) S VALMHDR(1)="Procedure: "_$P(^GMR(123.3,+GMRCPROC,0),U)
52 I $D(GMRCSV) S VALMHDR(1)="Service: "_$P(^GMR(123.5,+GMRCSV,0),U)
53 S VALMHDR(2)="Patient: "_$$GET1^DIQ(2,+GMRCPAT,.01)
54 Q
55 ;
56INIT ; -- init variables and list array
57 Q:$D(^TMP("GMRCRFR",$J))
58 D GETDEF($NA(^TMP("GMRCRFR",$J)),$S($D(GMRCSV):GMRCSV,1:GMRCPROC),GMRCPAT,1)
59 I '$D(^TMP("GMRCRFR",$J)) D
60 . S ^TMP("GMRCRFR",$J,1,0)="No default Reason for Request exists for the selected item."
61 S VALMCNT=$O(^TMP("GMRCRFR",$J,999999),-1)
62 S VALMBG=1
63 Q
64 ;
65HELP ; -- help code
66 S X="?" D DISP^XQORM1 W !!
67 Q
68 ;
69EXIT ; -- exit code
70 K GMRCSV,GMRCPAT,GMRCPROC
71 Q
72 ;
73EXPND ; -- expand code
74 Q
75 ;
76GETDEF(GMRCARR,GMRCSRV,GMRCDFN,RESOLV) ; return default reason for request
77 ; GMRCARR = array to return containing default RFR
78 ; GMRCSRV = reference to file 123.5 (#;99CON) or file 123.3 (#;99PRC)
79 ; GMRCDFN = patient identifier if to return resolved
80 ; RESOLV = 1 or 0 ; if RESOLV=1 GMRCARR will be returned resolved
81 Q:'+GMRCSRV
82 N GMRCFIL
83 S GMRCFIL=$S(GMRCSRV[";99PRC":123.3,1:123.5)
84 Q:'$D(^GMR(GMRCFIL,+GMRCSRV,124))
85 I '$D(GMRCDFN)!('$G(RESOLV)) D Q
86 . M @GMRCARR=^GMR(GMRCFIL,+GMRCSRV,124)
87 D BLRPLT^TIUSRVD(,,GMRCDFN,,$NA(^GMR(GMRCFIL,+GMRCSRV,124)))
88 I $D(^TMP("TIUBOIL",$J)) M @GMRCARR=^TMP("TIUBOIL",$J)
89 K ^TMP("TIUBOIL",$J)
90 Q
91REAF(GMRCOI) ;return value of RESTRICT DEFAULT REASON EDIT field to CPRS
92 ;Input:
93 ; GMRCOI - ref to file 123.5 (ien;99CON) or file 123.3 (ien;99PRC)
94 ;Output:
95 ; Integer 0 - unrestricted
96 ; 1 - ask on edit only
97 ; 2 - no editing
98 ;
99 N FILE
100 S FILE=$S(GMRCOI["99PRC":123.3,1:123.5)
101 I '$O(^GMR(FILE,+GMRCOI,124,0)) Q 0
102 I FILE=123.5 Q +$P($G(^GMR(FILE,+GMRCOI,1)),U,3) ;cslt service
103 Q +$P($G(^GMR(FILE,+GMRCOI,0)),U,9) ;procedure
Note: See TracBrowser for help on using the repository browser.