source: FOIAVistA/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCHL7B.m@ 1733

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1GMRCHL7B ;SLC/DCM,MA,JFR - Process data from GMRCHL7A ; 3/7/03 14:42
2 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22,33**;DEC 27, 1997
3 ;
4 ; This routine invokes IA #3991
5 ;
6NEW(MESSAGE) ;Add new order
7 ;GMRCO=^GMR(123,IFN, the new file number in file ^GMR(123,
8 ;GMRCORFN=OE/RR file number GMRCWARD=ward patient is on
9 ;GMRCSS=service consult sent to GMRCAD=date/time of request
10 ;GMRCPRI=procedure/request GMRCURGI=urgency
11 ;GMRCATN=attention GMRCSTS=OE/RR order status
12 ;GMRCORNP=patient's provider GMRCTYPE=request type (request or consult)
13 ;GMRCSBR=service rendered on what basis (Inpatient, or Outpatient)
14 ;GMRCRFQ=reason for request array - word processing fields
15 ;GMRCOTXT=order display text from dialog or orderable item
16 ;GMRCPRDG=provisional DX
17 ;GMRCPRCD=provisional DX code
18 ;
19 ; Output:
20 ; MESSAGE = rejection message if problems encountered while filing
21 ;
22 ; check for inactive ICD-9 code in Prov. DX
23 I $L($G(GMRCPRCD)) D I $D(MESSAGE) Q ; rejected due to inactive code
24 . I +$$STATCHK^ICDAPIU(GMRCPRCD,DT) Q ;code is OK
25 . S MESSAGE="Provisional DX code is inactive. Unable to file request."
26 ;
27 N DIC,DLAYGO,X,DR,DIE,GMRCADUZ,GMRCCP
28 S DIC="^GMR(123,",DIC(0)="L",X="""N""",DLAYGO=123 D ^DIC K DLAYGO Q:Y<1
29 ; Patch #21 changed GMRCA=1 to GMRCA=2
30 S (DA,GMRCO)=+Y,GMRCSTS=5,GMRCA=2,DIE=DIC
31 L +^GMR(123,GMRCO)
32 S DR=".02////^S X=DFN;.03////^S X=GMRCORFN;.04////^S X=GMRCWARD;.05////^S X=GMRCFAC;.06////^S X=$G(GMRCOFN);1////^S X=GMRCSS;2////^S X=$G(GMRCWARD);3////^S X=GMRCAD;4////^S X=GMRCPRI;5////^S X=GMRCURGI;7////^S X=$G(GMRCATN)"
33 D ^DIE
34 I GMRCOTXT=$$GET1^DIQ(123.5,+GMRCSS,.01) S GMRCOTXT=""
35 ;Added new field .1 to DR on 7/11/98 to save the order text
36 S DR="6////^S X=GMRCPLI;8////^S X=GMRCSTS;9////^S X=GMRCA;10////^S X=GMRCORNP;13////^S X=GMRCTYPE;14////^S X=$G(GMRCSBR);30////^S X=$G(GMRCPRDG);.1////^S X=$G(GMRCOTXT)"
37 I $D(GMRCPRCD) S DR=DR_";30.1///^S X=GMRCPRCD"
38 S GMRCCP=$P($G(^GMR(123.3,+GMRCPRI,0)),U,4) I GMRCCP D ;file CP
39 . S DR=DR_";1.01///^S X=GMRCCP"
40 D ;check to see if an IFC and add .07 ROUTING FACILITY
41 . I $G(GMRCPRI) D Q ;see if procedure is mapped
42 .. I '$D(^GMR(123.3,+GMRCPRI,"IFC")) Q
43 .. N IFC S IFC=$G(^GMR(123.3,+GMRCPRI,"IFC"))
44 .. I '+IFC Q ; no ifc routing site
45 .. I '$L($P(^GMR(123.3,+GMRCPRI,"IFC"),U,2)) Q ;no remote proc name
46 .. S DR=DR_";.07////"_+IFC_";.125////P"
47 . I '$G(GMRCPRI) D Q ;see if service is mapped
48 .. I '$D(^GMR(123.5,+GMRCSS,"IFC")) Q
49 .. N IFC S IFC=$G(^GMR(123.5,+GMRCSS,"IFC"))
50 .. I '+IFC Q ; no ifc routing site
51 .. I '$L($P(IFC,U,2)) Q ;no remote service name
52 .. S DR=DR_";.07////"_+IFC_";.125////P;.131////"_$P(IFC,U,2)
53 . Q
54 D ^DIE
55 I $O(GMRCRFQ(0)) D REASON
56 L -^GMR(123,GMRCO)
57 S GMRCA=1 D AUDIT0^GMRCHL7U
58 I $D(GMRCXMF),$D(GMRCOFN) S $P(^GMR(123,GMRCO,0),"^",21)=GMRCOFN
59 I $D(GMRCACTN) S GMRCADUZ(GMRCACTN)=""
60 D ALERT^GMRCHL7U(DFN,GMRCSS,GMRCPRI,GMRCO,GMRCURGI,"")
61 D PRNT^GMRCUTL1(GMRCSS,GMRCO) ;contains print audit update
62 D EXIT
63 Q
64DC(GMRCO,ACTRL) ;Discontinue request from OERR
65 ;Denied request also gets this action. Deny request updates status to dc
66 ;GMRCO=IEN of record in file ^GMR(123, i.e., ^GMR(123,DA,
67 ;ACTRL=GMRCCTRL=control code defining action -
68 ; DC control code = action DC for discontinued
69 ; CA control code = action DY for denied
70 ;Update the last action taken, order status, and processing activity
71 Q:'$L(GMRCO)
72 Q:'$D(^GMR(123,+GMRCO,0))
73 N GMRCACT,GMRCSVC,GMRCDFN,GMRCFL,GMRCADUZ,GMRCRQR,DA
74 S GMRCACT=$O(^GMR(123.1,"D",ACTRL,0))
75 S GMRCSTS=$P(^GMR(123.1,GMRCACT,0),"^",2)
76 S DIE="^GMR(123,",DA=GMRCO
77 S DR="8////^S X=GMRCSTS;9////^S X=GMRCACT" ; upd status + last action
78 D ^DIE
79 D AUDIT0^GMRCHL7U
80 ; send 513 back through service printer if order DC'd
81 I $G(ACTRL)="DC",$$DCPRNT^GMRCUTL1(GMRCO,DUZ) D
82 . D PRNT^GMRCUTL1(+$P(^GMR(123,GMRCO,0),U,5),GMRCO)
83 S GMRCDFN=$P(^GMR(123,+GMRCO,0),"^",2)
84 S GMRCFL=$$DCNOTE^GMRCADC(GMRCO,DUZ),GMRCADUZ=""
85 S GMRCRQR=+$P($G(^GMR(123,+GMRCO,0)),"^",14)
86 I +GMRCRQR,GMRCRQR'=DUZ S GMRCADUZ(GMRCRQR)=""
87 S GMRCSVC=$P($G(^GMR(123,+GMRCO,0)),"^",5)
88 I +GMRCSVC S GMRCSVC=$S($D(^GMR(123.5,GMRCSVC,.1)):^(.1),1:$P(^GMR(123.5,GMRCSVC,0),"^",1))
89 E S GMRCSVC="Unknown Service: Consult # "_GMRCO
90 S GMRCORTX=$S(ACTRL="DC":"Discontinued",1:"Cancelled")
91 S GMRCORTX=GMRCORTX_" Consult "_$$ORTX^GMRCAU(GMRCO)
92 N NOTYPE S NOTYPE=$S(ACTRL="DC":23,1:30)
93 D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
94 D EXIT
95 Q
96MODIFY ;Change an order/request when an HL7 'XX' code is received
97 ;This is currently not used.
98 ; When Consults sends an XX, CPRS returns NA with a new order ien.
99 ;GMRCACT=processing activity - from file ^GMR(123.1,
100 S DIE="^GMR(123,",DA=+GMRCO
101 S GMRCWARD=$G(GMRCWARD),GMRCPRI=$G(GMRCPRI),GMRCURGI=$G(GMRCURGI),GMRCSTS=$G(GMRCSTS),GMRCTYPE=$G(GMRCTYPE),GMRCSS=$G(GMRCSS)
102 S GMRCACT=$O(^GMR(123.1,"D",GMRCTRLC,0))
103 S GMRCSTS=$P(^GMR(123.1,GMRCACT,0),"^",2)
104 S DIE=123,DR=".04////^S X=$G(GMRCWARD);1////^S X=$G(GMRCSS);4////^S X=$G(GMRCPRI);5////^S X=$G(GMRCURGI);8////^S X=$G(GMRCSTS);9////^S X=GMRCACT"
105 D ^DIE
106 D AUDIT0^GMRCHL7U
107 D EXIT Q
108REASON ;load the reason for request into ^GMR(123,IFN,20
109 S ^GMR(123,GMRCO,20,0)="^^^"_$S($D(GMRCDA):GMRCDA,1:DT)_"^"
110 S L=0,LN=1 F S L=$O(GMRCRFQ(L)) Q:L="" S ^GMR(123,GMRCO,20,LN,0)=GMRCRFQ(L),LN=LN+1
111 S LN=LN-1,$P(^GMR(123,GMRCO,20,0),"^",3)=LN
112 K L,LN
113 Q
114COMMENT(GMRCARY) ;add comments to the record. Add the comment header, then the comment lines, and lastly, the number of comment lines to the header
115 ;GMRCARY= GMRCNTC array
116 S LN=0,^GMR(123,GMRCO,40,DA,1,0)="^^^^"_$P(GMRCDA,".",1)_"^"
117 F S LN=$O(GMRCARY(LN)) Q:LN="" S ^GMR(123,+GMRCO,40,DA,1,LN,0)=GMRCARY(LN),LN1=LN
118 S $P(^GMR(123,+GMRCO,40,DA,1,0),"^",3,4)=LN1_"^"_LN1
119 K LN,LN1 Q
120 Q
121EXIT ;kill off all variables
122 K DA,DIC,DIE,DR,GMRCORTX,GMRCADUZ
123 Q
Note: See TracBrowser for help on using the repository browser.