RMPRHL7B ;HINES/HNC - Process order parameters set file 668 ;3-21-00
;;3.0;PROSTHETICS;**45,52,62,78**;Feb 09, 1996
;
; ODJ - patch 52 - 10/13/00 - remove leading blank lines from
; consult text
; RVD - patch 62 - update ICD9 field from the HL7 message.
; TH - patch 78 - 09/26/03 - update ICD9 codes, value for each SC and
; EI.
;
NEW ;Create new suspense
;
;RMPRO=^RMPR(668,IFN, the new file number in file ^RMPR(668,
;RMPRORFN=OE/RR file number (pointer to Order file)
;RMPRWARD=ward patient is on
;RMPRSS=type of consult
;RMPRAD=date/time of request
;RMPRPRI=procedure/request
;RMPRURGI=urgency POINTER 101 TO FREE T
;RMPRORNP=patient's ordering provider
;RMPRTYPE=request type (request or consult)
;RMPRSBR=service rendered on what basis (Inpatient, or Outpatient)
;RMPRRFQ=reason for request array - word processing fields
;RMPRPRDG=provisional DX
;RMPRPRCD=provisional DX code
;
;
;next 4 lines added by patch #62
S RMPRIECD=""
I $D(RMPRPRCD),RMPRPRCD'="" D
.S RMPRIECD=$O(^ICD9("BA",RMPRPRCD,0))
.I '$G(RMPRIECD) S RMPRIECD=$O(^ICD9("BA",RMPRPRCD_" ",0))
; next 5 lines added by patch #78
; override previous Provisional Diagnosis code with first BA code
I $D(RMPRMSG1(1,1)) S RMPRPRCD=$$GET1^DIQ(80,RMPRMSG1(1,1)_",",.01),RMPRIECD=RMPRMSG1(1,1)
I '$G(RMPRIECD) D
. 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
;
N DIC,DLAYGO,X,DR,DIE
S DIC="^RMPR(668,",DIC(0)="L",X="""N""",DLAYGO=668 D ^DIC K DLAYGO Q:Y<1
S (DA,RMPRO)=+Y,DIE=DIC
;
L +^RMPR(668,RMPRO)
; .01-Suspense date;22-Date RX written
S DR=".01////^S X=RMPRAD;22////^S X=RMPRAD"
; 1-Veteran;19-CPRS order #;2-station;9-Type or request;2.3-Urgency
; 30-Consult Visit#
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"
D ^DIE
;
; 8-Suspense by (ordering provider);14-Status (O=Open);
; 3-Suspense form (9=for other);13-Requestor (ordering provider)
; 1.5-Provisional Diagnosis;1.6-ICD9
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)"
D ^DIE
;
; Patch 78: Update ICD9 and value of each SC and EI.
S RMPRMAX=8 ; ao - cv
F RMPRI=1:1:99 Q:'$D(RMPRMSG1(RMPRI)) S DR="" D
. F RMPRJ=1:1:RMPRMAX S RMVALUE=$G(RMPRMSG1(RMPRI,RMPRJ)) D
. . S DR=DR_"3"_(RMPRI-1)_$S(RMPRJ>1:"."_(RMPRJ-1),1:"")_"////^S X="
. . S DR=DR_$S(RMVALUE="":"""""",1:RMVALUE)_$S(RMPRJ<RMPRMAX:";",1:"")
. . D ^DIE
; following lines deleted by WLC 05/24/04
; New BA Phase II modifications for multiples
;S RMPRMAX=8
;F RMPRI=1:1:99 Q:'$D(RMPRMSG1(RMPRI)) K FDA D
;. S FDA(668.02,"+"_RMPRI_","_RMPRO_",",.01)=RMPRMSG1(RMPRI,1)
;. F RMPRJ=2:1:RMPRMAX S RMVALUE=$G(RMPRMSG1(RMPRI,RMPRJ)) D
;. . S FDA(668.02,"+"_RMPRI_","_RMPRO_",","30."_RMPRJ)=RMVALUE
;. S DIE=668.02
;. D UPDATE^DIE(,"FDA") I $D(^TMP("DIERR",$J))
;K FDA
;
I $O(RMPRRFQ(0)) D REASON
L -^RMPR(668,RMPRO)
;
D REASON
D EXIT
Q
REASON ;load the reason for request into description of item field 4
;^RMPR(668,D0,2,D1,0)
;
N RMPRC
S ^RMPR(668,RMPRO,2,0)="^^^"_$S($D(RMPRDA):RMPRDA,1:DT)_"^"
S RMPRL=0,RMPRLN=0
F S RMPRL=$O(RMPRRFQ(RMPRL)) Q:RMPRL="" D
. I 'RMPRLN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
.. S RMPRC=$E($TR(RMPRRFQ(RMPRL)," ","")) ;1st non space char
.. 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
.. Q
. S RMPRLN=RMPRLN+1,^RMPR(668,RMPRO,2,RMPRLN,0)=RMPRRFQ(RMPRL)
. Q
S $P(^RMPR(668,RMPRO,2,0),"^",3)=RMPRLN
K RMPRL,RMPRLN
Q
;
EXIT ;common exit
K DA,DIC,DIE,DR,RMPRORTX
K RMPRI,RMPRJ,RMPRMAX,RMVALUE,RMPRMSG1,RMPRPRCD,RMPRIECD
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRHL7B 3948 printed Apr 09, 2024@21:36:03 Page 2
RMPRHL7B ;HINES/HNC - Process order parameters set file 668 ;3-21-00
+1 ;;3.0;PROSTHETICS;**45,52,62,78**;Feb 09, 1996
+2 ;
+3 ; ODJ - patch 52 - 10/13/00 - remove leading blank lines from
+4 ; consult text
+5 ; RVD - patch 62 - update ICD9 field from the HL7 message.
+6 ; TH - patch 78 - 09/26/03 - update ICD9 codes, value for each SC and
+7 ; EI.
+8 ;
NEW ;Create new suspense
+1 ;
+2 ;RMPRO=^RMPR(668,IFN, the new file number in file ^RMPR(668,
+3 ;RMPRORFN=OE/RR file number (pointer to Order file)
+4 ;RMPRWARD=ward patient is on
+5 ;RMPRSS=type of consult
+6 ;RMPRAD=date/time of request
+7 ;RMPRPRI=procedure/request
+8 ;RMPRURGI=urgency POINTER 101 TO FREE T
+9 ;RMPRORNP=patient's ordering provider
+10 ;RMPRTYPE=request type (request or consult)
+11 ;RMPRSBR=service rendered on what basis (Inpatient, or Outpatient)
+12 ;RMPRRFQ=reason for request array - word processing fields
+13 ;RMPRPRDG=provisional DX
+14 ;RMPRPRCD=provisional DX code
+15 ;
+16 ;
+17 ;next 4 lines added by patch #62
+18 SET RMPRIECD=""
+19 IF $DATA(RMPRPRCD)
IF RMPRPRCD'=""
Begin DoDot:1
+20 SET RMPRIECD=$ORDER(^ICD9("BA",RMPRPRCD,0))
+21 IF '$GET(RMPRIECD)
SET RMPRIECD=$ORDER(^ICD9("BA",RMPRPRCD_" ",0))
End DoDot:1
+22 ; next 5 lines added by patch #78
+23 ; override previous Provisional Diagnosis code with first BA code
+24 IF $DATA(RMPRMSG1(1,1))
SET RMPRPRCD=$$GET1^DIQ(80,RMPRMSG1(1,1)_",",.01)
SET RMPRIECD=RMPRMSG1(1,1)
+25 IF '$GET(RMPRIECD)
Begin DoDot:1
+26 NEW RMLP
FOR RMLP=2:1:4
IF $DATA(RMPRMSG1(RMLP,1))
SET RMPRPRCD=$$GET1^DIQ(RMPRMSG1(RMLP,1)_",",.01)
SET RMPRIECD=RMPRMSG1(RMLP,1)
QUIT
End DoDot:1
+27 ;
+28 NEW DIC,DLAYGO,X,DR,DIE
+29 SET DIC="^RMPR(668,"
SET DIC(0)="L"
SET X="""N"""
SET DLAYGO=668
DO ^DIC
KILL DLAYGO
if Y<1
QUIT
+30 SET (DA,RMPRO)=+Y
SET DIE=DIC
+31 ;
+32 LOCK +^RMPR(668,RMPRO)
+33 ; .01-Suspense date;22-Date RX written
+34 SET DR=".01////^S X=RMPRAD;22////^S X=RMPRAD"
+35 ; 1-Veteran;19-CPRS order #;2-station;9-Type or request;2.3-Urgency
+36 ; 30-Consult Visit#
+37 SET 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"
+38 DO ^DIE
+39 ;
+40 ; 8-Suspense by (ordering provider);14-Status (O=Open);
+41 ; 3-Suspense form (9=for other);13-Requestor (ordering provider)
+42 ; 1.5-Provisional Diagnosis;1.6-ICD9
+43 SET 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)"
+44 DO ^DIE
+45 ;
+46 ; Patch 78: Update ICD9 and value of each SC and EI.
+47 ; ao - cv
SET RMPRMAX=8
+48 FOR RMPRI=1:1:99
if '$DATA(RMPRMSG1(RMPRI))
QUIT
SET DR=""
Begin DoDot:1
+49 FOR RMPRJ=1:1:RMPRMAX
SET RMVALUE=$GET(RMPRMSG1(RMPRI,RMPRJ))
Begin DoDot:2
+50 SET DR=DR_"3"_(RMPRI-1)_$SELECT(RMPRJ>1:"."_(RMPRJ-1),1:"")_"////^S X="
+51 SET DR=DR_$SELECT(RMVALUE="":"""""",1:RMVALUE)_$SELECT(RMPRJ<RMPRMAX:";",1:"")
+52 DO ^DIE
End DoDot:2
End DoDot:1
+53 ; following lines deleted by WLC 05/24/04
+54 ; New BA Phase II modifications for multiples
+55 ;S RMPRMAX=8
+56 ;F RMPRI=1:1:99 Q:'$D(RMPRMSG1(RMPRI)) K FDA D
+57 ;. S FDA(668.02,"+"_RMPRI_","_RMPRO_",",.01)=RMPRMSG1(RMPRI,1)
+58 ;. F RMPRJ=2:1:RMPRMAX S RMVALUE=$G(RMPRMSG1(RMPRI,RMPRJ)) D
+59 ;. . S FDA(668.02,"+"_RMPRI_","_RMPRO_",","30."_RMPRJ)=RMVALUE
+60 ;. S DIE=668.02
+61 ;. D UPDATE^DIE(,"FDA") I $D(^TMP("DIERR",$J))
+62 ;K FDA
+63 ;
+64 IF $ORDER(RMPRRFQ(0))
DO REASON
+65 LOCK -^RMPR(668,RMPRO)
+66 ;
+67 DO REASON
+68 DO EXIT
+69 QUIT
REASON ;load the reason for request into description of item field 4
+1 ;^RMPR(668,D0,2,D1,0)
+2 ;
+3 NEW RMPRC
+4 SET ^RMPR(668,RMPRO,2,0)="^^^"_$SELECT($DATA(RMPRDA):RMPRDA,1:DT)_"^"
+5 SET RMPRL=0
SET RMPRLN=0
+6 FOR
SET RMPRL=$ORDER(RMPRRFQ(RMPRL))
if RMPRL=""
QUIT
Begin DoDot:1
+7 ;strip leading space from 1st line, ignore blank line
IF 'RMPRLN
Begin DoDot:2
+8 ;1st non space char
SET RMPRC=$EXTRACT($TRANSLATE(RMPRRFQ(RMPRL)," ",""))
+9 ;extract from 1st non space char to end of line
if RMPRC'=""
SET RMPRRFQ(RMPRL)=$EXTRACT(RMPRRFQ(RMPRL),$FIND(RMPRRFQ(RMPRL),RMPRC)-1,$LENGTH(RMPRRFQ(RMPRL)))
+10 QUIT
End DoDot:2
if RMPRC=""
QUIT
+11 SET RMPRLN=RMPRLN+1
SET ^RMPR(668,RMPRO,2,RMPRLN,0)=RMPRRFQ(RMPRL)
+12 QUIT
End DoDot:1
+13 SET $PIECE(^RMPR(668,RMPRO,2,0),"^",3)=RMPRLN
+14 KILL RMPRL,RMPRLN
+15 QUIT
+16 ;
EXIT ;common exit
+1 KILL DA,DIC,DIE,DR,RMPRORTX
+2 KILL RMPRI,RMPRJ,RMPRMAX,RMVALUE,RMPRMSG1,RMPRPRCD,RMPRIECD
+3 QUIT
+4 ;END
