source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRHL7B.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1RMPRHL7B ;HINES/HNC - Process order parameters set file 668 ;3-21-00
2 ;;3.0;PROSTHETICS;**45,52,62,78**;Feb 09, 1996
3 ;
4 ; ODJ - patch 52 - 10/13/00 - remove leading blank lines from
5 ; consult text
6 ; RVD - patch 62 - update ICD9 field from the HL7 message.
7 ; TH - patch 78 - 09/26/03 - update ICD9 codes, value for each SC and
8 ; EI.
9 ;
10NEW ;Create new suspense
11 ;
12 ;RMPRO=^RMPR(668,IFN, the new file number in file ^RMPR(668,
13 ;RMPRORFN=OE/RR file number (pointer to Order file)
14 ;RMPRWARD=ward patient is on
15 ;RMPRSS=type of consult
16 ;RMPRAD=date/time of request
17 ;RMPRPRI=procedure/request
18 ;RMPRURGI=urgency POINTER 101 TO FREE T
19 ;RMPRORNP=patient's ordering provider
20 ;RMPRTYPE=request type (request or consult)
21 ;RMPRSBR=service rendered on what basis (Inpatient, or Outpatient)
22 ;RMPRRFQ=reason for request array - word processing fields
23 ;RMPRPRDG=provisional DX
24 ;RMPRPRCD=provisional DX code
25 ;
26 ;
27 ;next 4 lines added by patch #62
28 S RMPRIECD=""
29 I $D(RMPRPRCD),RMPRPRCD'="" D
30 .S RMPRIECD=$O(^ICD9("BA",RMPRPRCD,0))
31 .I '$G(RMPRIECD) S RMPRIECD=$O(^ICD9("BA",RMPRPRCD_" ",0))
32 ; next 5 lines added by patch #78
33 ; override previous Provisional Diagnosis code with first BA code
34 I $D(RMPRMSG1(1,1)) S RMPRPRCD=$$GET1^DIQ(80,RMPRMSG1(1,1)_",",.01),RMPRIECD=RMPRMSG1(1,1)
35 I '$G(RMPRIECD) D
36 . N RMLP F RMLP=2:1:4 I $D(RMPRMSG1(RMLP,1)) S RMPRPRCD=$$GET1^DIQ(RMPRMSG1(RMLP,1)_",",.01),RMPRIECD=RMPRMSG1(RMLP,1) Q
37 ;
38 N DIC,DLAYGO,X,DR,DIE
39 S DIC="^RMPR(668,",DIC(0)="L",X="""N""",DLAYGO=668 D ^DIC K DLAYGO Q:Y<1
40 S (DA,RMPRO)=+Y,DIE=DIC
41 ;
42 L +^RMPR(668,RMPRO)
43 ; .01-Suspense date;22-Date RX written
44 S DR=".01////^S X=RMPRAD;22////^S X=RMPRAD"
45 ; 1-Veteran;19-CPRS order #;2-station;9-Type or request;2.3-Urgency
46 ; 30-Consult Visit#
47 S DR=DR_";1////^S X=DFN;19////^S X=RMPRORFN;2////^S X=RMPRFAC;9////^S X=RMPRSS;2.3////^S X=RMPRURGI;30////^S X=VISIT"
48 D ^DIE
49 ;
50 ; 8-Suspense by (ordering provider);14-Status (O=Open);
51 ; 3-Suspense form (9=for other);13-Requestor (ordering provider)
52 ; 1.5-Provisional Diagnosis;1.6-ICD9
53 S DR="8////^S X=RMPRORNP;14////^S X=""O"";3////^S X=9;13////^S X=RMPRORNP;1.5////^S X=$G(RMPRPRDG);1.6////^S X=$G(RMPRIECD)"
54 D ^DIE
55 ;
56 ; Patch 78: Update ICD9 and value of each SC and EI.
57 S RMPRMAX=8 ; ao - cv
58 F RMPRI=1:1:99 Q:'$D(RMPRMSG1(RMPRI)) S DR="" D
59 . F RMPRJ=1:1:RMPRMAX S RMVALUE=$G(RMPRMSG1(RMPRI,RMPRJ)) D
60 . . S DR=DR_"3"_(RMPRI-1)_$S(RMPRJ>1:"."_(RMPRJ-1),1:"")_"////^S X="
61 . . S DR=DR_$S(RMVALUE="":"""""",1:RMVALUE)_$S(RMPRJ<RMPRMAX:";",1:"")
62 . . D ^DIE
63 ; following lines deleted by WLC 05/24/04
64 ; New BA Phase II modifications for multiples
65 ;S RMPRMAX=8
66 ;F RMPRI=1:1:99 Q:'$D(RMPRMSG1(RMPRI)) K FDA D
67 ;. S FDA(668.02,"+"_RMPRI_","_RMPRO_",",.01)=RMPRMSG1(RMPRI,1)
68 ;. F RMPRJ=2:1:RMPRMAX S RMVALUE=$G(RMPRMSG1(RMPRI,RMPRJ)) D
69 ;. . S FDA(668.02,"+"_RMPRI_","_RMPRO_",","30."_RMPRJ)=RMVALUE
70 ;. S DIE=668.02
71 ;. D UPDATE^DIE(,"FDA") I $D(^TMP("DIERR",$J))
72 ;K FDA
73 ;
74 I $O(RMPRRFQ(0)) D REASON
75 L -^RMPR(668,RMPRO)
76 ;
77 D REASON
78 D EXIT
79 Q
80REASON ;load the reason for request into description of item field 4
81 ;^RMPR(668,D0,2,D1,0)
82 ;
83 N RMPRC
84 S ^RMPR(668,RMPRO,2,0)="^^^"_$S($D(RMPRDA):RMPRDA,1:DT)_"^"
85 S RMPRL=0,RMPRLN=0
86 F S RMPRL=$O(RMPRRFQ(RMPRL)) Q:RMPRL="" D
87 . I 'RMPRLN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
88 .. S RMPRC=$E($TR(RMPRRFQ(RMPRL)," ","")) ;1st non space char
89 .. S:RMPRC'="" RMPRRFQ(RMPRL)=$E(RMPRRFQ(RMPRL),$F(RMPRRFQ(RMPRL),RMPRC)-1,$L(RMPRRFQ(RMPRL))) ;extract from 1st non space char to end of line
90 .. Q
91 . S RMPRLN=RMPRLN+1,^RMPR(668,RMPRO,2,RMPRLN,0)=RMPRRFQ(RMPRL)
92 . Q
93 S $P(^RMPR(668,RMPRO,2,0),"^",3)=RMPRLN
94 K RMPRL,RMPRLN
95 Q
96 ;
97EXIT ;common exit
98 K DA,DIC,DIE,DR,RMPRORTX
99 K RMPRI,RMPRJ,RMPRMAX,RMVALUE,RMPRMSG1,RMPRPRCD,RMPRIECD
100 Q
101 ;END
Note: See TracBrowser for help on using the repository browser.