GMRCHL7B ;SLC/DCM,MA,JFR - Process data from GMRCHL7A ; 12/1/20 4:43pm
;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22,33,66,46,73,85,96,145,168**;DEC 27, 1997;Build 3
;
; This routine invokes IA #2053(DIE), #10006(DIC), #2056(GET1^DIQ), #5747$$CODECS^ICDEX
;
; ABV/SCR: 09/26/2007 *96*- Modified to include population of UNIQUE CONSULT ID field
; Patch 145 - adds GMRCDSID
NEW(MESSAGE) ;Add new order
;GMRCO=^GMR(123,IFN, the new file number in file ^GMR(123,
;GMRCORFN=OE/RR file number GMRCWARD=ward patient is on
;GMRCSS=service consult sent to GMRCAD=date/time of request
;GMRCPRI=procedure/request GMRCURGI=urgency
;GMRCERDT=clinically ind date
;GMRCATN=attention GMRCSTS=OE/RR order status
;GMRCORNP=patient's provider GMRCTYPE=request type (request or consult)
;GMRCSBR=service rendered on what basis (Inpatient, or Outpatient)
;GMRCRFQ=reason for request array - word processing fields
;GMRCOTXT=order display text from dialog or orderable item
;GMRCPRDG=provisional DX
;GMRCPRCD=provisional DX code
;GMRCCS=coding system for prov diagnosis
;GMRCCPTR=pointer to coding system file
;GMRCUCID=consult unique ID GMRCDSID=decision support tool id
; Output:
; MESSAGE = rejection message if problems encountered while filing
;
;
N DIC,DLAYGO,X,Y,DR,DIE,GMRCADUZ,GMRCCP,GMRCCS,GMRCUCID ;ABV/SCR 09/26/2017
S DIC="^GMR(123,",DIC(0)="L",X="""N""",DLAYGO=123 D ^DIC K DLAYGO Q:Y<1
; Patch #21 changed GMRCA=1 to GMRCA=2
S (DA,GMRCO)=+Y,GMRCSTS=5,GMRCA=2,DIE=DIC
S GMRCUCID=$$NEWUCID^GMRCUTL1(DA) ;ABV/SCR 09/26/2017
I GMRCUCID="" S ^XTMP("GMRCHL7B","UCID IS BLANK",DA)=DA ;ABV/SCR 12/14/2017 - TEMPORARY ERROR HANDLER
L +^GMR(123,GMRCO):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
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)"
D ^DIE
I GMRCOTXT=$$GET1^DIQ(123.5,+GMRCSS,.01) S GMRCOTXT=""
;Added new field .1 to DR on 7/11/98 to save the order text
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);17////^S X=$G(GMRCERDT);30////^S X=$G(GMRCPRDG);.1////^S X=$G(GMRCOTXT);80////^S X=GMRCUCID" ;ABV/SCR 12/14/17 *96*
S DR=DR_";85////^S X=$G(GMRCDSID)"
I $D(GMRCPRCD) D
.S GMRCCS=""
.S GMRCCS=$$CODECS^ICDEX(GMRCPRCD,80) I $G(GMRCCS)'="" D ;use dx code to get coding system
..S GMRCCS=$S($P(GMRCCS,U)=1:"ICD",1:"10D")
.S DR=DR_";30.1///^S X=GMRCPRCD;30.2////^S X=DT;30.3////^S X=GMRCCS"
S GMRCCP=$P($G(^GMR(123.3,+GMRCPRI,0)),U,4) I GMRCCP D ;file CP
. S DR=DR_";1.01///^S X=GMRCCP"
D ;check to see if an IFC and add .07 ROUTING FACILITY
. I $G(GMRCPRI) D Q ;see if procedure is mapped
.. I '$D(^GMR(123.3,+GMRCPRI,"IFC")) Q
.. N IFC S IFC=$G(^GMR(123.3,+GMRCPRI,"IFC"))
.. I '+IFC Q ; no ifc routing site
.. I '$L($P(^GMR(123.3,+GMRCPRI,"IFC"),U,2)) Q ;no remote proc name
.. S DR=DR_";.07////"_+IFC_";.125////P"
. I '$G(GMRCPRI) D Q ;see if service is mapped
.. I '$D(^GMR(123.5,+GMRCSS,"IFC")) Q
.. N IFC S IFC=$G(^GMR(123.5,+GMRCSS,"IFC"))
.. I '+IFC Q ; no ifc routing site
.. I '$L($P(IFC,U,2)) Q ;no remote service name
.. S DR=DR_";.07////"_+IFC_";.125////P;.131////"_$P(IFC,U,2)
. Q
D ^DIE
I $O(GMRCRFQ(0)) D REASON
L -^GMR(123,GMRCO)
S GMRCA=1 D AUDIT0^GMRCHL7U
I $D(GMRCXMF),$D(GMRCOFN) S $P(^GMR(123,GMRCO,0),"^",21)=GMRCOFN
I $D(GMRCACTN) S GMRCADUZ(GMRCACTN)=""
D ALERT^GMRCHL7U(DFN,GMRCSS,GMRCPRI,GMRCO,GMRCURGI,"")
D PRNT^GMRCUTL1(GMRCSS,GMRCO) ;contains print audit update
D EXIT
Q
DC(GMRCO,ACTRL) ;Discontinue request from OERR
;Denied request also gets this action. Deny request updates status to dc
;GMRCO=IEN of record in file ^GMR(123, i.e., ^GMR(123,DA,
;ACTRL=GMRCCTRL=control code defining action -
; DC control code = action DC for discontinued
; CA control code = action DY for denied
;Update the last action taken, order status, and processing activity
Q:'$L(GMRCO)
Q:'$D(^GMR(123,+GMRCO,0))
N GMRCACT,GMRCSVC,GMRCDFN,GMRCFL,GMRCADUZ,GMRCRQR,DA
S GMRCACT=$O(^GMR(123.1,"D",ACTRL,0))
S GMRCSTS=$P(^GMR(123.1,GMRCACT,0),"^",2)
S DIE="^GMR(123,",DA=GMRCO
S DR="8////^S X=GMRCSTS;9////^S X=GMRCACT" ; upd status + last action
D ^DIE
D AUDIT0^GMRCHL7U
; send 513 back through service printer if order DC'd
I $G(ACTRL)="DC",$$DCPRNT^GMRCUTL1(GMRCO,DUZ) D
. D PRNT^GMRCUTL1(+$P(^GMR(123,GMRCO,0),U,5),GMRCO)
S GMRCDFN=$P(^GMR(123,+GMRCO,0),"^",2)
S GMRCFL=$$DCNOTE^GMRCADC(GMRCO,DUZ),GMRCADUZ=""
S GMRCRQR=+$P($G(^GMR(123,+GMRCO,0)),"^",14)
I +GMRCRQR,GMRCRQR'=DUZ S GMRCADUZ(GMRCRQR)=""
S GMRCSVC=$P($G(^GMR(123,+GMRCO,0)),"^",5)
I +GMRCSVC S GMRCSVC=$S($D(^GMR(123.5,GMRCSVC,.1)):^(.1),1:$P(^GMR(123.5,GMRCSVC,0),"^",1))
E S GMRCSVC="Unknown Service: Consult # "_GMRCO
S GMRCORTX=$S(ACTRL="DC":"Discontinued",1:"Cancelled")
S GMRCORTX=GMRCORTX_" Consult "_$$ORTX^GMRCAU(GMRCO)
N NOTYPE S NOTYPE=$S(ACTRL="DC":23,1:30)
D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
D EXIT
Q
MODIFY ;Change an order/request when an HL7 'XX' code is received
;This is currently not used.
; When Consults sends an XX, CPRS returns NA with a new order ien.
;GMRCACT=processing activity - from file ^GMR(123.1,
S DIE="^GMR(123,",DA=+GMRCO
S GMRCWARD=$G(GMRCWARD),GMRCPRI=$G(GMRCPRI),GMRCURGI=$G(GMRCURGI),GMRCSTS=$G(GMRCSTS),GMRCTYPE=$G(GMRCTYPE),GMRCSS=$G(GMRCSS)
S GMRCACT=$O(^GMR(123.1,"D",GMRCTRLC,0))
S GMRCSTS=$P(^GMR(123.1,GMRCACT,0),"^",2)
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"
D ^DIE
D AUDIT0^GMRCHL7U
D EXIT Q
REASON ;load the reason for request into ^GMR(123,IFN,20
S ^GMR(123,GMRCO,20,0)="^^^"_$S($D(GMRCDA):GMRCDA,1:DT)_"^"
S L=0,LN=1 F S L=$O(GMRCRFQ(L)) Q:L="" S GMRCRFQ(LN)=$$CHKTXT^GMRCHL7U(GMRCRFQ(LN)),^GMR(123,GMRCO,20,LN,0)=GMRCRFQ(L),LN=LN+1
S LN=LN-1,$P(^GMR(123,GMRCO,20,0),"^",3)=LN
K L,LN
Q
;GMRCARY= GMRCNTC array
I $D(GMRCARY) Q:($E(GMRCARY(1),1,6)="dstid_")
S LN=0,^GMR(123,GMRCO,40,DA,1,0)="^^^^"_$P(GMRCDA,".",1)_"^"
F S LN=$O(GMRCARY(LN)) Q:LN="" S GMRCARY(LN)=$$CHKTXT^GMRCHL7U(GMRCARY(LN)),^GMR(123,+GMRCO,40,DA,1,LN,0)=GMRCARY(LN),LN1=LN
S $P(^GMR(123,+GMRCO,40,DA,1,0),"^",3,4)=LN1_"^"_LN1
K LN,LN1 Q
Q
EXIT ;kill off all variables
K DA,DIC,DIE,DR,GMRCORTX,GMRCADUZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCHL7B 6756 printed Apr 09, 2024@20:52:24 Page 2
GMRCHL7B ;SLC/DCM,MA,JFR - Process data from GMRCHL7A ; 12/1/20 4:43pm
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22,33,66,46,73,85,96,145,168**;DEC 27, 1997;Build 3
+2 ;
+3 ; This routine invokes IA #2053(DIE), #10006(DIC), #2056(GET1^DIQ), #5747$$CODECS^ICDEX
+4 ;
+5 ; ABV/SCR: 09/26/2007 *96*- Modified to include population of UNIQUE CONSULT ID field
+6 ; Patch 145 - adds GMRCDSID
NEW(MESSAGE) ;Add new order
+1 ;GMRCO=^GMR(123,IFN, the new file number in file ^GMR(123,
+2 ;GMRCORFN=OE/RR file number GMRCWARD=ward patient is on
+3 ;GMRCSS=service consult sent to GMRCAD=date/time of request
+4 ;GMRCPRI=procedure/request GMRCURGI=urgency
+5 ;GMRCERDT=clinically ind date
+6 ;GMRCATN=attention GMRCSTS=OE/RR order status
+7 ;GMRCORNP=patient's provider GMRCTYPE=request type (request or consult)
+8 ;GMRCSBR=service rendered on what basis (Inpatient, or Outpatient)
+9 ;GMRCRFQ=reason for request array - word processing fields
+10 ;GMRCOTXT=order display text from dialog or orderable item
+11 ;GMRCPRDG=provisional DX
+12 ;GMRCPRCD=provisional DX code
+13 ;GMRCCS=coding system for prov diagnosis
+14 ;GMRCCPTR=pointer to coding system file
+15 ;GMRCUCID=consult unique ID GMRCDSID=decision support tool id
+16 ; Output:
+17 ; MESSAGE = rejection message if problems encountered while filing
+18 ;
+19 ;
+20 ;ABV/SCR 09/26/2017
NEW DIC,DLAYGO,X,Y,DR,DIE,GMRCADUZ,GMRCCP,GMRCCS,GMRCUCID
+21 SET DIC="^GMR(123,"
SET DIC(0)="L"
SET X="""N"""
SET DLAYGO=123
DO ^DIC
KILL DLAYGO
if Y<1
QUIT
+22 ; Patch #21 changed GMRCA=1 to GMRCA=2
+23 SET (DA,GMRCO)=+Y
SET GMRCSTS=5
SET GMRCA=2
SET DIE=DIC
+24 ;ABV/SCR 09/26/2017
SET GMRCUCID=$$NEWUCID^GMRCUTL1(DA)
+25 ;ABV/SCR 12/14/2017 - TEMPORARY ERROR HANDLER
IF GMRCUCID=""
SET ^XTMP("GMRCHL7B","UCID IS BLANK",DA)=DA
+26 LOCK +^GMR(123,GMRCO):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+27 SET 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)"
+28 DO ^DIE
+29 IF GMRCOTXT=$$GET1^DIQ(123.5,+GMRCSS,.01)
SET GMRCOTXT=""
+30 ;Added new field .1 to DR on 7/11/98 to save the order text
+31 ;ABV/SCR 12/14/17 *96*
SET 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);17////^S X=$G(GMRCERDT);30////^S X=$G(GMRCPRDG);.1////^S X=$G(GMRCOTXT);80////^S X=GMRCUCID"
+32 SET DR=DR_";85////^S X=$G(GMRCDSID)"
+33 IF $DATA(GMRCPRCD)
Begin DoDot:1
+34 SET GMRCCS=""
+35 ;use dx code to get coding system
SET GMRCCS=$$CODECS^ICDEX(GMRCPRCD,80)
IF $GET(GMRCCS)'=""
Begin DoDot:2
+36 SET GMRCCS=$SELECT($PIECE(GMRCCS,U)=1:"ICD",1:"10D")
End DoDot:2
+37 SET DR=DR_";30.1///^S X=GMRCPRCD;30.2////^S X=DT;30.3////^S X=GMRCCS"
End DoDot:1
+38 ;file CP
SET GMRCCP=$PIECE($GET(^GMR(123.3,+GMRCPRI,0)),U,4)
IF GMRCCP
Begin DoDot:1
+39 SET DR=DR_";1.01///^S X=GMRCCP"
End DoDot:1
+40 ;check to see if an IFC and add .07 ROUTING FACILITY
Begin DoDot:1
+41 ;see if procedure is mapped
IF $GET(GMRCPRI)
Begin DoDot:2
+42 IF '$DATA(^GMR(123.3,+GMRCPRI,"IFC"))
QUIT
+43 NEW IFC
SET IFC=$GET(^GMR(123.3,+GMRCPRI,"IFC"))
+44 ; no ifc routing site
IF '+IFC
QUIT
+45 ;no remote proc name
IF '$LENGTH($PIECE(^GMR(123.3,+GMRCPRI,"IFC"),U,2))
QUIT
+46 SET DR=DR_";.07////"_+IFC_";.125////P"
End DoDot:2
QUIT
+47 ;see if service is mapped
IF '$GET(GMRCPRI)
Begin DoDot:2
+48 IF '$DATA(^GMR(123.5,+GMRCSS,"IFC"))
QUIT
+49 NEW IFC
SET IFC=$GET(^GMR(123.5,+GMRCSS,"IFC"))
+50 ; no ifc routing site
IF '+IFC
QUIT
+51 ;no remote service name
IF '$LENGTH($PIECE(IFC,U,2))
QUIT
+52 SET DR=DR_";.07////"_+IFC_";.125////P;.131////"_$PIECE(IFC,U,2)
End DoDot:2
QUIT
+53 QUIT
End DoDot:1
+54 DO ^DIE
+55 IF $ORDER(GMRCRFQ(0))
DO REASON
+56 LOCK -^GMR(123,GMRCO)
+57 SET GMRCA=1
DO AUDIT0^GMRCHL7U
+58 IF $DATA(GMRCXMF)
IF $DATA(GMRCOFN)
SET $PIECE(^GMR(123,GMRCO,0),"^",21)=GMRCOFN
+59 IF $DATA(GMRCACTN)
SET GMRCADUZ(GMRCACTN)=""
+60 DO ALERT^GMRCHL7U(DFN,GMRCSS,GMRCPRI,GMRCO,GMRCURGI,"")
+61 ;contains print audit update
DO PRNT^GMRCUTL1(GMRCSS,GMRCO)
+62 DO EXIT
+63 QUIT
DC(GMRCO,ACTRL) ;Discontinue request from OERR
+1 ;Denied request also gets this action. Deny request updates status to dc
+2 ;GMRCO=IEN of record in file ^GMR(123, i.e., ^GMR(123,DA,
+3 ;ACTRL=GMRCCTRL=control code defining action -
+4 ; DC control code = action DC for discontinued
+5 ; CA control code = action DY for denied
+6 ;Update the last action taken, order status, and processing activity
+7 if '$LENGTH(GMRCO)
QUIT
+8 if '$DATA(^GMR(123,+GMRCO,0))
QUIT
+9 NEW GMRCACT,GMRCSVC,GMRCDFN,GMRCFL,GMRCADUZ,GMRCRQR,DA
+10 SET GMRCACT=$ORDER(^GMR(123.1,"D",ACTRL,0))
+11 SET GMRCSTS=$PIECE(^GMR(123.1,GMRCACT,0),"^",2)
+12 SET DIE="^GMR(123,"
SET DA=GMRCO
+13 ; upd status + last action
SET DR="8////^S X=GMRCSTS;9////^S X=GMRCACT"
+14 DO ^DIE
+15 DO AUDIT0^GMRCHL7U
+16 ; send 513 back through service printer if order DC'd
+17 IF $GET(ACTRL)="DC"
IF $$DCPRNT^GMRCUTL1(GMRCO,DUZ)
Begin DoDot:1
+18 DO PRNT^GMRCUTL1(+$PIECE(^GMR(123,GMRCO,0),U,5),GMRCO)
End DoDot:1
+19 SET GMRCDFN=$PIECE(^GMR(123,+GMRCO,0),"^",2)
+20 SET GMRCFL=$$DCNOTE^GMRCADC(GMRCO,DUZ)
SET GMRCADUZ=""
+21 SET GMRCRQR=+$PIECE($GET(^GMR(123,+GMRCO,0)),"^",14)
+22 IF +GMRCRQR
IF GMRCRQR'=DUZ
SET GMRCADUZ(GMRCRQR)=""
+23 SET GMRCSVC=$PIECE($GET(^GMR(123,+GMRCO,0)),"^",5)
+24 IF +GMRCSVC
SET GMRCSVC=$SELECT($DATA(^GMR(123.5,GMRCSVC,.1)):^(.1),1:$PIECE(^GMR(123.5,GMRCSVC,0),"^",1))
+25 IF '$TEST
SET GMRCSVC="Unknown Service: Consult # "_GMRCO
+26 SET GMRCORTX=$SELECT(ACTRL="DC":"Discontinued",1:"Cancelled")
+27 SET GMRCORTX=GMRCORTX_" Consult "_$$ORTX^GMRCAU(GMRCO)
+28 NEW NOTYPE
SET NOTYPE=$SELECT(ACTRL="DC":23,1:30)
+29 DO MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
+30 DO EXIT
+31 QUIT
MODIFY ;Change an order/request when an HL7 'XX' code is received
+1 ;This is currently not used.
+2 ; When Consults sends an XX, CPRS returns NA with a new order ien.
+3 ;GMRCACT=processing activity - from file ^GMR(123.1,
+4 SET DIE="^GMR(123,"
SET DA=+GMRCO
+5 SET GMRCWARD=$GET(GMRCWARD)
SET GMRCPRI=$GET(GMRCPRI)
SET GMRCURGI=$GET(GMRCURGI)
SET GMRCSTS=$GET(GMRCSTS)
SET GMRCTYPE=$GET(GMRCTYPE)
SET GMRCSS=$GET(GMRCSS)
+6 SET GMRCACT=$ORDER(^GMR(123.1,"D",GMRCTRLC,0))
+7 SET GMRCSTS=$PIECE(^GMR(123.1,GMRCACT,0),"^",2)
+8 SET DIE=123
SET 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"
+9 DO ^DIE
+10 DO AUDIT0^GMRCHL7U
+11 DO EXIT
QUIT
REASON ;load the reason for request into ^GMR(123,IFN,20
+1 SET ^GMR(123,GMRCO,20,0)="^^^"_$SELECT($DATA(GMRCDA):GMRCDA,1:DT)_"^"
+2 SET L=0
SET LN=1
FOR
SET L=$ORDER(GMRCRFQ(L))
if L=""
QUIT
SET GMRCRFQ(LN)=$$CHKTXT^GMRCHL7U(GMRCRFQ(LN))
SET ^GMR(123,GMRCO,20,LN,0)=GMRCRFQ(L)
SET LN=LN+1
+3 SET LN=LN-1
SET $PIECE(^GMR(123,GMRCO,20,0),"^",3)=LN
+4 KILL L,LN
+5 QUIT
+1 ;GMRCARY= GMRCNTC array
+2 IF $DATA(GMRCARY)
if ($EXTRACT(GMRCARY(1),1,6)="dstid_")
QUIT
+3 SET LN=0
SET ^GMR(123,GMRCO,40,DA,1,0)="^^^^"_$PIECE(GMRCDA,".",1)_"^"
+4 FOR
SET LN=$ORDER(GMRCARY(LN))
if LN=""
QUIT
SET GMRCARY(LN)=$$CHKTXT^GMRCHL7U(GMRCARY(LN))
SET ^GMR(123,+GMRCO,40,DA,1,LN,0)=GMRCARY(LN)
SET LN1=LN
+5 SET $PIECE(^GMR(123,+GMRCO,40,DA,1,0),"^",3,4)=LN1_"^"_LN1
+6 KILL LN,LN1
QUIT
+7 QUIT
EXIT ;kill off all variables
+1 KILL DA,DIC,DIE,DR,GMRCORTX,GMRCADUZ
+2 QUIT
