GMRCHL7B ;SLC/DCM,MA,JFR - Process data from GMRCHL7A ;16-Apr-2014 14:23;DU
;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22,33,1004**;DEC 27, 1997;Build 12
;IHS/MSC/MGH major changes in patch 1004 to accomodate SNOMED and
;V CarePlaning files for MU stage II
; This routine invokes IA #3991
;
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
;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
;GMRCPRPB=problem IEN
;
; Output:
; MESSAGE = rejection message if problems encountered while filing
;
; check for inactive ICD-9 code in Prov. DX
;I $L($G(GMRCPRCD)) D I $D(MESSAGE) Q ; rejected due to inactive code
;. I +$$STATCHK^ICDAPIU(GMRCPRCD,DT) Q ;code is OK
;. S MESSAGE="Provisional DX code is inactive. Unable to file request."
;
N DIC,DLAYGO,X,DR,DIE,GMRCADUZ,GMRCCP,SNOMED
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
L +^GMR(123,GMRCO)
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);30////^S X=$G(GMRCPRDG);.1////^S X=$G(GMRCOTXT)"
I $D(GMRCPRCD) S DR=DR_";30.1///^S X=GMRCPRCD"
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
;IHS/MSC/MGH Patch 1004 Add SNOMED CT if stores
S SNOMED=$$GET1^DIQ(123.5,GMRCSS,9999999.01)
I SNOMED'="" D
.I '$D(GMRCPRPB) S GMRCPRPB=""
.S DR="9999999.01////"_SNOMED_";9999999.02////"_GMRCPRPB
.D ^DIE
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 ^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
S LN=0,^GMR(123,GMRCO,40,DA,1,0)="^^^^"_$P(GMRCDA,".",1)_"^"
F S LN=$O(GMRCARY(LN)) Q:LN="" S ^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
GMRCHL7B ;SLC/DCM,MA,JFR - Process data from GMRCHL7A ;16-Apr-2014 14:23;DU
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22,33,1004**;DEC 27, 1997;Build 12
+2 ;IHS/MSC/MGH major changes in patch 1004 to accomodate SNOMED and
+3 ;V CarePlaning files for MU stage II
+4 ; This routine invokes IA #3991
+5 ;
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 ;GMRCATN=attention GMRCSTS=OE/RR order status
+6 ;GMRCORNP=patient's provider GMRCTYPE=request type (request or consult)
+7 ;GMRCSBR=service rendered on what basis (Inpatient, or Outpatient)
+8 ;GMRCRFQ=reason for request array - word processing fields
+9 ;GMRCOTXT=order display text from dialog or orderable item
+10 ;GMRCPRDG=provisional DX
+11 ;GMRCPRCD=provisional DX code
+12 ;GMRCPRPB=problem IEN
+13 ;
+14 ; Output:
+15 ; MESSAGE = rejection message if problems encountered while filing
+16 ;
+17 ; check for inactive ICD-9 code in Prov. DX
+18 ;I $L($G(GMRCPRCD)) D I $D(MESSAGE) Q ; rejected due to inactive code
+19 ;. I +$$STATCHK^ICDAPIU(GMRCPRCD,DT) Q ;code is OK
+20 ;. S MESSAGE="Provisional DX code is inactive. Unable to file request."
+21 ;
+22 NEW DIC,DLAYGO,X,DR,DIE,GMRCADUZ,GMRCCP,SNOMED
+23 SET DIC="^GMR(123,"
SET DIC(0)="L"
SET X="""N"""
SET DLAYGO=123
DO ^DIC
KILL DLAYGO
IF Y<1
QUIT
+24 ; Patch #21 changed GMRCA=1 to GMRCA=2
+25 SET (DA,GMRCO)=+Y
SET GMRCSTS=5
SET GMRCA=2
SET DIE=DIC
+26 LOCK +^GMR(123,GMRCO)
+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 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);30////^S X=$G(GMRCPRDG);.1////^S X=$G(GMRCOTXT)"
+32 IF $DATA(GMRCPRCD)
SET DR=DR_";30.1///^S X=GMRCPRCD"
+33 ;file CP
SET GMRCCP=$PIECE($GET(^GMR(123.3,+GMRCPRI,0)),U,4)
IF GMRCCP
Begin DoDot:1
+34 SET DR=DR_";1.01///^S X=GMRCCP"
End DoDot:1
+35 ;check to see if an IFC and add .07 ROUTING FACILITY
Begin DoDot:1
+36 ;see if procedure is mapped
IF $GET(GMRCPRI)
Begin DoDot:2
+37 IF '$DATA(^GMR(123.3,+GMRCPRI,"IFC"))
QUIT
+38 NEW IFC
SET IFC=$GET(^GMR(123.3,+GMRCPRI,"IFC"))
+39 ; no ifc routing site
IF '+IFC
QUIT
+40 ;no remote proc name
IF '$LENGTH($PIECE(^GMR(123.3,+GMRCPRI,"IFC"),U,2))
QUIT
+41 SET DR=DR_";.07////"_+IFC_";.125////P"
End DoDot:2
QUIT
+42 ;see if service is mapped
IF '$GET(GMRCPRI)
Begin DoDot:2
+43 IF '$DATA(^GMR(123.5,+GMRCSS,"IFC"))
QUIT
+44 NEW IFC
SET IFC=$GET(^GMR(123.5,+GMRCSS,"IFC"))
+45 ; no ifc routing site
IF '+IFC
QUIT
+46 ;no remote service name
IF '$LENGTH($PIECE(IFC,U,2))
QUIT
+47 SET DR=DR_";.07////"_+IFC_";.125////P;.131////"_$PIECE(IFC,U,2)
End DoDot:2
QUIT
+48 QUIT
End DoDot:1
+49 DO ^DIE
+50 IF $ORDER(GMRCRFQ(0))
DO REASON
+51 ;IHS/MSC/MGH Patch 1004 Add SNOMED CT if stores
+52 SET SNOMED=$$GET1^DIQ(123.5,GMRCSS,9999999.01)
+53 IF SNOMED'=""
Begin DoDot:1
+54 IF '$DATA(GMRCPRPB)
SET GMRCPRPB=""
+55 SET DR="9999999.01////"_SNOMED_";9999999.02////"_GMRCPRPB
+56 DO ^DIE
End DoDot:1
+57 LOCK -^GMR(123,GMRCO)
+58 SET GMRCA=1
DO AUDIT0^GMRCHL7U
+59 IF $DATA(GMRCXMF)
IF $DATA(GMRCOFN)
SET $PIECE(^GMR(123,GMRCO,0),"^",21)=GMRCOFN
+60 IF $DATA(GMRCACTN)
SET GMRCADUZ(GMRCACTN)=""
+61 DO ALERT^GMRCHL7U(DFN,GMRCSS,GMRCPRI,GMRCO,GMRCURGI,"")
+62 ;contains print audit update
DO PRNT^GMRCUTL1(GMRCSS,GMRCO)
+63 DO EXIT
+64 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 ^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 SET LN=0
SET ^GMR(123,GMRCO,40,DA,1,0)="^^^^"_$PIECE(GMRCDA,".",1)_"^"
+3 FOR
SET LN=$ORDER(GMRCARY(LN))
IF LN=""
QUIT
SET ^GMR(123,+GMRCO,40,DA,1,LN,0)=GMRCARY(LN)
SET LN1=LN
+4 SET $PIECE(^GMR(123,+GMRCO,40,DA,1,0),"^",3,4)=LN1_"^"_LN1
+5 KILL LN,LN1
QUIT
+6 QUIT
EXIT ;kill off all variables
+1 KILL DA,DIC,DIE,DR,GMRCORTX,GMRCADUZ
+2 QUIT
