GMRCHL7B.m

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

COMMENT(GMRCARY) ;add comments to the record.  Add the comment header, then the comment lines, and lastly, the number of comment lines to the header

 ;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 

COMMENT(GMRCARY) ;add comments to the record.  Add the comment header, then the comment lines, and lastly, the number of comment lines to the header

 +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