GMRCEDT1 ;SLC/DCM,JFR - EDIT A CONSULT AND RE-SEND AS NEW ;10/14/15 11:53
;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,47,66,73,85,81**;DEC 27, 1997;Build 6
;
; This routine invokes IA #2638 (^ORD(100.01,), #5699 (ICDXCODE), #10117 (VALM10)
; #10103 (XLFDT), #10104 (XLFSTR), #10060 (access ^VA(200)), #2056 (GET1^DIQ)
;
EN(GMRCO) ;GMRCO=IEN of consult from file 123
;GMRCSS=To Service GMRCPROC=Procedure Request Type
;GMRCURG=Urgency GMRCPL=Place Of Consultation
;GMRCATN=Attention GMRCINO=Service is In/Out Patient
;GMRCPNM=Patient Name GMRCDIAG=Provisional Diagnosis
;GMRCERDT=Clinically Indicated Date
;GMRCPROS=Prosthetics Service y/n
;GMRCCPTR=pointer to coding systems file
;GMRCCSYS=provisional diagnosis code sys GMRCCODE=provisional diagnosis code
N GMRCSS,GMRCPROC,GMRCURG,GMRCPL,GMRCATN,GMRCINO,GMRCDIAG,LN,GMRCRESP,GMRCERDT,GMRCPROS,IDX,GMRCDATE,GMRCCSYS,GMRCCODE
N GMRCLBL,BUFFER,REPEAT
S REPEAT=24
K ^TMP("GMRCR",$J,"ED") S GMRCLNO=1
I $L($P(^GMR(123,+GMRCO,0),"^",12)) S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=" CURRENT STATUS: (Not Editable): "_$P(^ORD(100.01,$P(^(0),"^",12),0),"^",1),GMRCLNO=GMRCLNO+1
S GMRCD=0 F S GMRCD=$O(^GMR(123,+GMRCO,40,"B",GMRCD)) Q:'GMRCD S GMRCDD="" F S GMRCDD=$O(^GMR(123,GMRCO,40,"B",GMRCD,GMRCDD)) Q:'GMRCDD D
.I $P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",2)=19 S LN=0 D
..N GMRCPERS,GMRCTX
..I '$D(^GMR(123,+GMRCO,12)) D
...S GMRCPERS=+$P($G(^GMR(123,+GMRCO,40,GMRCDD,0)),"^",5)
...S GMRCPERS=$$GET1^DIQ(200,GMRCPERS,.01)
..I $D(^GMR(123,+GMRCO,12)) D
...I $P(^GMR(123,+GMRCO,12),U,5)="P" D
....S GMRCPERS=$P($G(^GMR(123,+GMRCO,40,GMRCDD,2)),U,1)
...I $P(^GMR(123,+GMRCO,12),U,5)="F" D
....S GMRCPERS=$P($G(^GMR(123,+GMRCO,40,GMRCDD,0)),U,5)
....S GMRCPERS=$$GET1^DIQ(200,GMRCPERS,.01)
..S GMRCTX=" CANCELLED BY (Not Editable): "_GMRCPERS
..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=GMRCTX,GMRCLNO=GMRCLNO+1
..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=" CANCELLED COMMENT (Not Editable):",GMRCLNO=GMRCLNO+1
..S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E) I $L(^GMR(123,+GMRCO,40,GMRCDD,1,LN,0))>75 S FLG=1 D WPSET^GMRCUTIL("^GMR(123,+GMRCO,40,GMRCDD,1)","^TMP(""GMRCR"",$J,""ED"")","",.GMRCLNO,"",FLG)
..I '$D(FLG) S LN=0 F S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E) S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^(LN,0),GMRCLNO=GMRCLNO+1
..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="",$P(^(0),"-",79)=""
..S GMRCLNO=GMRCLNO+1
..Q
.Q
S GMRCSS=$S($D(GMRCEDT(1)):GMRCEDT(1),1:$P(^GMR(123,+GMRCO,0),"^",5)_U_$P(^GMR(123.5,$P(^GMR(123,+GMRCO,0),"^",5),0),U))
S GMRCPROC=$S($D(GMRCED(1)):GMRCED(1),1:$P(^GMR(123,+GMRCO,0),"^",8)_U_$$GET1^DIQ(123.3,+$P(^GMR(123,+GMRCO,0),"^",8),.01))
I $D(GMRCED(2)) S GMRCINO=GMRCED(2)
I '$D(GMRCINO) S GMRCINO=$P(^GMR(123,+GMRCO,0),U,18)_U_$S($P(^(0),U,18)="I":"Inpatient",1:"Outpatient")
S GMRCURG=$S($D(GMRCED(3)):GMRCED(3),1:$P(^GMR(123,+GMRCO,0),"^",9)_U_$$GET1^DIQ(101,+$P(^(0),"^",9),1))
S GMRCPL=$S($D(GMRCED(4)):GMRCED(4),1:$P(^GMR(123,+GMRCO,0),"^",10)_U_$$GET1^DIQ(101,+$P(^(0),U,10),1))
S GMRCPROS=$G(^GMR(123.5,$P(GMRCSS,U),"INT")) I $G(GMRCPROS)="" D
.S GMRCERDT=$S($D(GMRCED(5)):GMRCED(5),1:$P(^GMR(123,+GMRCO,0),"^",24)_U_$$FMTE^XLFDT($P(^GMR(123,GMRCO,0),U,24)))
S GMRCATN=$S($D(GMRCED(6)):GMRCED(6),1:$P(^GMR(123,+GMRCO,0),"^",11)_U_$$GET1^DIQ(200,+$P(^(0),U,11),.01))
I '$D(^GMR(123,GMRCO,30.1)) D
. I $D(GMRCED(7)),$L($P(GMRCED(7),U,2)) D Q
.. S GMRCDIAG=$P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"
. S GMRCDIAG=$S($D(GMRCED(7)):GMRCED(7),1:$G(^GMR(123,+GMRCO,30)))
I $D(^GMR(123,GMRCO,30.1)) D
. S GMRCCODE=$P($G(^GMR(123,+GMRCO,30.1)),"^",1)
. S GMRCCSYS=$P($G(^GMR(123,+GMRCO,30.1)),"^",3)
. S:$G(GMRCCSYS)="ICD" GMRCLBL="(ICD-9-CM "_$G(GMRCCODE)_")"
. S:$G(GMRCCSYS)="10D" GMRCLBL="(ICD-10-CM "_$G(GMRCCODE)_")"
. I $D(GMRCED(7)),$L(GMRCED(7)) D Q
.. S GMRCDIAG=$P(GMRCED(7),U)
.. S GMRCCODE=$P(GMRCED(7),U,2)
.. S GMRCCSYS=$$CODECS^ICDEX($G(GMRCCODE),80) ;WAT/85 use dx code to get coding system
.. S GMRCLBL="" ;just in case coding system is null
.. S:GMRCCSYS="ICD" GMRCLBL="(ICD-9-CM "_GMRCCODE_")"
.. S:GMRCCSYS="10D" GMRCLBL="(ICD-10-CM "_GMRCCODE_")"
.. S GMRCDIAG=$G(GMRCDIAG)_$G(GMRCLBL)
. S GMRCDIAG=$G(^GMR(123,+GMRCO,30))_$G(GMRCLBL)
S GMRCREQ=$S(+$P(^GMR(123,+GMRCO,0),U,17)="P":"Procedure",1:"Consult")
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="SENDING PROVIDER (Not Editable): "_$S($P($G(^GMR(123,+GMRCO,12)),U,6):$P(^GMR(123,+GMRCO,12),U,6),$P(^GMR(123,+GMRCO,0),"^",14):$$GET1^DIQ(200,+$P(^GMR(123,+GMRCO,0),"^",14),.01),1:"UNKNOWN"),GMRCLNO=GMRCLNO+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="REQUEST TYPE (Not Editable): "_GMRCREQ,GMRCLNO=GMRCLNO+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=$$REPEAT^XLFSTR("-",79),GMRCLNO=GMRCLNO+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=" TO SERVICE (Not Editable): "_$P(GMRCSS,U,2) S GMRCLNO=GMRCLNO+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=" ",GMRCLNO=GMRCLNO+1
S IDX=1,^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" PROCEDURE: "_$P(GMRCPROC,U,2)
D:+GMRCPROC RVRS(GMRCLNO,$D(GMRCED(IDX))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" Performed as INPT OR OUTPT: "_$P(GMRCINO,U,2) D RVRS(GMRCLNO,$D(GMRCED(2))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" URGENCY: "_$P(GMRCURG,U,2) D RVRS(GMRCLNO,$D(GMRCED(3))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" PLACE OF CONSULTATION: "_$P(GMRCPL,U,2) D RVRS(GMRCLNO,$D(GMRCED(4))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
I $G(GMRCPROS)="" S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" CLINICALLY INDICATED DATE: "_$P(GMRCERDT,U,2) D RVRS(GMRCLNO,$D(GMRCED(5))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" ATTENTION (CONSULTANT): "_$P(GMRCATN,U,2) D RVRS(GMRCLNO,$D(GMRCED(6))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
I $L($G(GMRCDIAG))<55 S:$G(FLG)="" ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" PROVISIONAL DIAGNOSIS: "_GMRCDIAG D RVRS(GMRCLNO,$D(GMRCED(7))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
I $L($G(GMRCDIAG))>54 D
.N PIECE,FLG S FLG=0
.F S PIECE=$L(GMRCDIAG) Q:PIECE<54 D
.. N SEG,I S I=2
.. F S SEG=$P(GMRCDIAG," ",1,I) Q:$L(SEG)>=54!($L(SEG," ")<I) S I=I+1
.. I $L(SEG)=$L(GMRCDIAG) S SEG=$E(GMRCDIAG,1,54) ;means GMRCDIAG doesn't contain spaces, e.g. v55,250.00,414.00,etc.
.. S BUFFER=SEG
.. S:SEG[" " SEG=$P(GMRCDIAG," ",1,(I-1)) I $L(SEG)=0 S SEG=$E(BUFFER,1,54) ;$P only good when SEG contains a space, otherwise grab a SEG from BUFFER
.. D KILL^VALM10(GMRCLNO)
.. S:FLG=0 ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" PROVISIONAL DIAGNOSIS: "_SEG D RVRS(GMRCLNO,$D(GMRCED(7)))
.. I FLG=1&($F(GMRCDIAG," ")'=2) S REPEAT=25
.. S:FLG=1 ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=$$REPEAT^XLFSTR(" ",REPEAT)_SEG
.. S FLG=1,GMRCLNO=GMRCLNO+1
.. S GMRCDIAG=$E(GMRCDIAG,$L(SEG)+1,999)
. I $F(GMRCD," ")'=2 S REPEAT=25
. S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=$$REPEAT^XLFSTR(" ",REPEAT)_GMRCDIAG
. S IDX=IDX+1,GMRCLNO=GMRCLNO+1
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" REASON FOR REQUEST:" D RVRS(GMRCLNO,$D(^TMP("GMRCED",$J,20))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1 D
. I $D(^TMP("GMRCED",$J,20)) D Q
.. N ND S ND=0
.. F S ND=$O(^TMP("GMRCED",$J,20,ND)) Q:'ND D
... D KILL^VALM10(GMRCLNO)
... S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCED",$J,20,ND,0)
... S GMRCLNO=GMRCLNO+1
. N ND S ND=0
. F S ND=$O(^GMR(123,+GMRCO,20,ND)) Q:ND="" D
.. S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^GMR(123,+GMRCO,20,ND,0)
.. S GMRCLNO=GMRCLNO+1
.Q
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="",GMRCLNO=GMRCLNO+1,^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" COMMENT(S): (Add Only)" D RVRS(GMRCLNO) S GMRCLNO=GMRCLNO+1
I $D(^TMP("GMRCED",$J,40)) D
. D KILL^VALM10(GMRCLNO)
. S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=" New Comment:",GMRCLNO=GMRCLNO+1
. N ND S ND=0 F S ND=$O(^TMP("GMRCED",$J,40,ND)) Q:'ND D
.. S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCED",$J,40,ND,0)
.. S GMRCLNO=GMRCLNO+1
N GMRCEDCT
S GMRCD=0,GMRCEDCT=0 F S GMRCD=$O(^GMR(123,+GMRCO,40,"B",GMRCD)) Q:'GMRCD S GMRCDD="",GMRCDD=$O(^GMR(123,+GMRCO,40,"B",GMRCD,GMRCDD)) Q:'GMRCDD D
.I $P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",2)=20 S LN=0,GMRCEDCT=GMRCEDCT+1,GMRCEDCM(GMRCEDCT)=GMRCDD D
..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="",GMRCLNO=GMRCLNO+1,^TMP("GMRCR",$J,"ED",GMRCLNO,0)="ADDED COMMENT (Not Editable) Entered: "_$P($$FMTE^XLFDT($P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",1)),"@",1)
..S GMRCRESP=$S($L($P($G(^GMR(123,+GMRCO,40,GMRCDD,0)),"^",5)):$$GET1^DIQ(200,$P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",5),.01),$L($P($G(^GMR(123,+GMRCO,40,GMRCDD,2)),"^",1)):$P(^GMR(123,+GMRCO,40,GMRCDD,2),"^",1),1:"UNKNOWN")
..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCR",$J,"ED",GMRCLNO,0)_" BY: "_GMRCRESP,GMRCLNO=GMRCLNO+1
..;S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCR",$J,"ED",GMRCLNO,0)_" BY: "_$S($L($P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",4)):$P(^VA(200,$P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",4),0),"^",1),1:"UNKNOWN"),GMRCLNO=GMRCLNO+1
..S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E) I $L(^GMR(123,+GMRCO,40,GMRCDD,1,LN,0))>75 S FLG=1 D WPSET^GMRCUTIL("^GMR(123,+GMRCO,40,GMRCDD,1)","^TMP(""GMRCR"",$J,""ED"")","",.GMRCLNO,"",FLG) Q
..S LN=0 F S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E) S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^(LN,0),GMRCLNO=GMRCLNO+1
..Q
.Q
S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=""
K FLG
Q
RVRS(LINE,EDITED) ;reverse video for fields that can be edited
I '$G(EDITED) D CNTRL^VALM10(LINE,1,1,IORVON,IORVOFF) Q
D CNTRL^VALM10(LINE,1,1,IORVON_IOINHI,IORVOFF_IOINORM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCEDT1 9524 printed Oct 16, 2024@17:46:23 Page 2
GMRCEDT1 ;SLC/DCM,JFR - EDIT A CONSULT AND RE-SEND AS NEW ;10/14/15 11:53
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,47,66,73,85,81**;DEC 27, 1997;Build 6
+2 ;
+3 ; This routine invokes IA #2638 (^ORD(100.01,), #5699 (ICDXCODE), #10117 (VALM10)
+4 ; #10103 (XLFDT), #10104 (XLFSTR), #10060 (access ^VA(200)), #2056 (GET1^DIQ)
+5 ;
EN(GMRCO) ;GMRCO=IEN of consult from file 123
+1 ;GMRCSS=To Service GMRCPROC=Procedure Request Type
+2 ;GMRCURG=Urgency GMRCPL=Place Of Consultation
+3 ;GMRCATN=Attention GMRCINO=Service is In/Out Patient
+4 ;GMRCPNM=Patient Name GMRCDIAG=Provisional Diagnosis
+5 ;GMRCERDT=Clinically Indicated Date
+6 ;GMRCPROS=Prosthetics Service y/n
+7 ;GMRCCPTR=pointer to coding systems file
+8 ;GMRCCSYS=provisional diagnosis code sys GMRCCODE=provisional diagnosis code
+9 NEW GMRCSS,GMRCPROC,GMRCURG,GMRCPL,GMRCATN,GMRCINO,GMRCDIAG,LN,GMRCRESP,GMRCERDT,GMRCPROS,IDX,GMRCDATE,GMRCCSYS,GMRCCODE
+10 NEW GMRCLBL,BUFFER,REPEAT
+11 SET REPEAT=24
+12 KILL ^TMP("GMRCR",$JOB,"ED")
SET GMRCLNO=1
+13 IF $LENGTH($PIECE(^GMR(123,+GMRCO,0),"^",12))
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=" CURRENT STATUS: (Not Editable): "_$PIECE(^ORD(100.01,$PIECE(^(0),"^",12),0),"^",1)
SET GMRCLNO=GMRCLNO+1
+14 SET GMRCD=0
FOR
SET GMRCD=$ORDER(^GMR(123,+GMRCO,40,"B",GMRCD))
if 'GMRCD
QUIT
SET GMRCDD=""
FOR
SET GMRCDD=$ORDER(^GMR(123,GMRCO,40,"B",GMRCD,GMRCDD))
if 'GMRCDD
QUIT
Begin DoDot:1
+15 IF $PIECE(^GMR(123,+GMRCO,40,GMRCDD,0),"^",2)=19
SET LN=0
Begin DoDot:2
+16 NEW GMRCPERS,GMRCTX
+17 IF '$DATA(^GMR(123,+GMRCO,12))
Begin DoDot:3
+18 SET GMRCPERS=+$PIECE($GET(^GMR(123,+GMRCO,40,GMRCDD,0)),"^",5)
+19 SET GMRCPERS=$$GET1^DIQ(200,GMRCPERS,.01)
End DoDot:3
+20 IF $DATA(^GMR(123,+GMRCO,12))
Begin DoDot:3
+21 IF $PIECE(^GMR(123,+GMRCO,12),U,5)="P"
Begin DoDot:4
+22 SET GMRCPERS=$PIECE($GET(^GMR(123,+GMRCO,40,GMRCDD,2)),U,1)
End DoDot:4
+23 IF $PIECE(^GMR(123,+GMRCO,12),U,5)="F"
Begin DoDot:4
+24 SET GMRCPERS=$PIECE($GET(^GMR(123,+GMRCO,40,GMRCDD,0)),U,5)
+25 SET GMRCPERS=$$GET1^DIQ(200,GMRCPERS,.01)
End DoDot:4
End DoDot:3
+26 SET GMRCTX=" CANCELLED BY (Not Editable): "_GMRCPERS
+27 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=GMRCTX
SET GMRCLNO=GMRCLNO+1
+28 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=" CANCELLED COMMENT (Not Editable):"
SET GMRCLNO=GMRCLNO+1
+29 SET LN=$ORDER(^GMR(123,+GMRCO,40,GMRCDD,1,LN))
if LN=""!(LN?1A.E)
QUIT
IF $LENGTH(^GMR(123,+GMRCO,40,GMRCDD,1,LN,0))>75
SET FLG=1
DO WPSET^GMRCUTIL("^GMR(123,+GMRCO,40,GMRCDD,1)","^TMP(""GMRCR"",$J,""ED"")","",.GMRCLNO,"",FLG)
+30 IF '$DATA(FLG)
SET LN=0
FOR
SET LN=$ORDER(^GMR(123,+GMRCO,40,GMRCDD,1,LN))
if LN=""!(LN?1A.E)
QUIT
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=^(LN,0)
SET GMRCLNO=GMRCLNO+1
+31 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=""
SET $PIECE(^(0),"-",79)=""
+32 SET GMRCLNO=GMRCLNO+1
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
+35 SET GMRCSS=$SELECT($DATA(GMRCEDT(1)):GMRCEDT(1),1:$PIECE(^GMR(123,+GMRCO,0),"^",5)_U_$PIECE(^GMR(123.5,$PIECE(^GMR(123,+GMRCO,0),"^",5),0),U))
+36 SET GMRCPROC=$SELECT($DATA(GMRCED(1)):GMRCED(1),1:$PIECE(^GMR(123,+GMRCO,0),"^",8)_U_$$GET1^DIQ(123.3,+$PIECE(^GMR(123,+GMRCO,0),"^",8),.01))
+37 IF $DATA(GMRCED(2))
SET GMRCINO=GMRCED(2)
+38 IF '$DATA(GMRCINO)
SET GMRCINO=$PIECE(^GMR(123,+GMRCO,0),U,18)_U_$SELECT($PIECE(^(0),U,18)="I":"Inpatient",1:"Outpatient")
+39 SET GMRCURG=$SELECT($DATA(GMRCED(3)):GMRCED(3),1:$PIECE(^GMR(123,+GMRCO,0),"^",9)_U_$$GET1^DIQ(101,+$PIECE(^(0),"^",9),1))
+40 SET GMRCPL=$SELECT($DATA(GMRCED(4)):GMRCED(4),1:$PIECE(^GMR(123,+GMRCO,0),"^",10)_U_$$GET1^DIQ(101,+$PIECE(^(0),U,10),1))
+41 SET GMRCPROS=$GET(^GMR(123.5,$PIECE(GMRCSS,U),"INT"))
IF $GET(GMRCPROS)=""
Begin DoDot:1
+42 SET GMRCERDT=$SELECT($DATA(GMRCED(5)):GMRCED(5),1:$PIECE(^GMR(123,+GMRCO,0),"^",24)_U_$$FMTE^XLFDT($PIECE(^GMR(123,GMRCO,0),U,24)))
End DoDot:1
+43 SET GMRCATN=$SELECT($DATA(GMRCED(6)):GMRCED(6),1:$PIECE(^GMR(123,+GMRCO,0),"^",11)_U_$$GET1^DIQ(200,+$PIECE(^(0),U,11),.01))
+44 IF '$DATA(^GMR(123,GMRCO,30.1))
Begin DoDot:1
+45 IF $DATA(GMRCED(7))
IF $LENGTH($PIECE(GMRCED(7),U,2))
Begin DoDot:2
+46 SET GMRCDIAG=$PIECE(GMRCED(7),U)_" ("_$PIECE(GMRCED(7),U,2)_")"
End DoDot:2
QUIT
+47 SET GMRCDIAG=$SELECT($DATA(GMRCED(7)):GMRCED(7),1:$GET(^GMR(123,+GMRCO,30)))
End DoDot:1
+48 IF $DATA(^GMR(123,GMRCO,30.1))
Begin DoDot:1
+49 SET GMRCCODE=$PIECE($GET(^GMR(123,+GMRCO,30.1)),"^",1)
+50 SET GMRCCSYS=$PIECE($GET(^GMR(123,+GMRCO,30.1)),"^",3)
+51 if $GET(GMRCCSYS)="ICD"
SET GMRCLBL="(ICD-9-CM "_$GET(GMRCCODE)_")"
+52 if $GET(GMRCCSYS)="10D"
SET GMRCLBL="(ICD-10-CM "_$GET(GMRCCODE)_")"
+53 IF $DATA(GMRCED(7))
IF $LENGTH(GMRCED(7))
Begin DoDot:2
+54 SET GMRCDIAG=$PIECE(GMRCED(7),U)
+55 SET GMRCCODE=$PIECE(GMRCED(7),U,2)
+56 ;WAT/85 use dx code to get coding system
SET GMRCCSYS=$$CODECS^ICDEX($GET(GMRCCODE),80)
+57 ;just in case coding system is null
SET GMRCLBL=""
+58 if GMRCCSYS="ICD"
SET GMRCLBL="(ICD-9-CM "_GMRCCODE_")"
+59 if GMRCCSYS="10D"
SET GMRCLBL="(ICD-10-CM "_GMRCCODE_")"
+60 SET GMRCDIAG=$GET(GMRCDIAG)_$GET(GMRCLBL)
End DoDot:2
QUIT
+61 SET GMRCDIAG=$GET(^GMR(123,+GMRCO,30))_$GET(GMRCLBL)
End DoDot:1
+62 SET GMRCREQ=$SELECT(+$PIECE(^GMR(123,+GMRCO,0),U,17)="P":"Procedure",1:"Consult")
+63 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)="SENDING PROVIDER (Not Editable): "_$SELECT($PIECE($GET(^GMR(123,+GMRCO,12)),U,6):$PIECE(^GMR(123,+GMRCO,12),U,6),$PIECE(^GMR(123,+GMRCO,0),"^",14):$$GET1^DIQ(200,+$PIECE(^GMR(123,+GMRCO,0),"^",14),.01),1:"
UNKNOWN")
SET GMRCLNO=GMRCLNO+1
+64 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)="REQUEST TYPE (Not Editable): "_GMRCREQ
SET GMRCLNO=GMRCLNO+1
+65 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=$$REPEAT^XLFSTR("-",79)
SET GMRCLNO=GMRCLNO+1
+66 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=" TO SERVICE (Not Editable): "_$PIECE(GMRCSS,U,2)
SET GMRCLNO=GMRCLNO+1
+67 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=" "
SET GMRCLNO=GMRCLNO+1
+68 SET IDX=1
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" PROCEDURE: "_$PIECE(GMRCPROC,U,2)
+69 if +GMRCPROC
DO RVRS(GMRCLNO,$DATA(GMRCED(IDX)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
+70 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" Performed as INPT OR OUTPT: "_$PIECE(GMRCINO,U,2)
DO RVRS(GMRCLNO,$DATA(GMRCED(2)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
+71 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" URGENCY: "_$PIECE(GMRCURG,U,2)
DO RVRS(GMRCLNO,$DATA(GMRCED(3)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
+72 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" PLACE OF CONSULTATION: "_$PIECE(GMRCPL,U,2)
DO RVRS(GMRCLNO,$DATA(GMRCED(4)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
+73 IF $GET(GMRCPROS)=""
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" CLINICALLY INDICATED DATE: "_$PIECE(GMRCERDT,U,2)
DO RVRS(GMRCLNO,$DATA(GMRCED(5)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
+74 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" ATTENTION (CONSULTANT): "_$PIECE(GMRCATN,U,2)
DO RVRS(GMRCLNO,$DATA(GMRCED(6)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
+75 IF $LENGTH($GET(GMRCDIAG))<55
if $GET(FLG)=""
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" PROVISIONAL DIAGNOSIS: "_GMRCDIAG
DO RVRS(GMRCLNO,$DATA(GMRCED(7)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
+76 IF $LENGTH($GET(GMRCDIAG))>54
Begin DoDot:1
+77 NEW PIECE,FLG
SET FLG=0
+78 FOR
SET PIECE=$LENGTH(GMRCDIAG)
if PIECE<54
QUIT
Begin DoDot:2
+79 NEW SEG,I
SET I=2
+80 FOR
SET SEG=$PIECE(GMRCDIAG," ",1,I)
if $LENGTH(SEG)>=54!($LENGTH(SEG," ")<I)
QUIT
SET I=I+1
+81 ;means GMRCDIAG doesn't contain spaces, e.g. v55,250.00,414.00,etc.
IF $LENGTH(SEG)=$LENGTH(GMRCDIAG)
SET SEG=$EXTRACT(GMRCDIAG,1,54)
+82 SET BUFFER=SEG
+83 ;$P only good when SEG contains a space, otherwise grab a SEG from BUFFER
if SEG[" "
SET SEG=$PIECE(GMRCDIAG," ",1,(I-1))
IF $LENGTH(SEG)=0
SET SEG=$EXTRACT(BUFFER,1,54)
+84 DO KILL^VALM10(GMRCLNO)
+85 if FLG=0
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" PROVISIONAL DIAGNOSIS: "_SEG
DO RVRS(GMRCLNO,$DATA(GMRCED(7)))
+86 IF FLG=1&($FIND(GMRCDIAG," ")'=2)
SET REPEAT=25
+87 if FLG=1
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=$$REPEAT^XLFSTR(" ",REPEAT)_SEG
+88 SET FLG=1
SET GMRCLNO=GMRCLNO+1
+89 SET GMRCDIAG=$EXTRACT(GMRCDIAG,$LENGTH(SEG)+1,999)
End DoDot:2
+90 IF $FIND(GMRCD," ")'=2
SET REPEAT=25
+91 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=$$REPEAT^XLFSTR(" ",REPEAT)_GMRCDIAG
+92 SET IDX=IDX+1
SET GMRCLNO=GMRCLNO+1
End DoDot:1
+93 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" REASON FOR REQUEST:"
DO RVRS(GMRCLNO,$DATA(^TMP("GMRCED",$JOB,20)))
SET GMRCLNO=GMRCLNO+1
SET IDX=IDX+1
Begin DoDot:1
+94 IF $DATA(^TMP("GMRCED",$JOB,20))
Begin DoDot:2
+95 NEW ND
SET ND=0
+96 FOR
SET ND=$ORDER(^TMP("GMRCED",$JOB,20,ND))
if 'ND
QUIT
Begin DoDot:3
+97 DO KILL^VALM10(GMRCLNO)
+98 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=^TMP("GMRCED",$JOB,20,ND,0)
+99 SET GMRCLNO=GMRCLNO+1
End DoDot:3
End DoDot:2
QUIT
+100 NEW ND
SET ND=0
+101 FOR
SET ND=$ORDER(^GMR(123,+GMRCO,20,ND))
if ND=""
QUIT
Begin DoDot:2
+102 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=^GMR(123,+GMRCO,20,ND,0)
+103 SET GMRCLNO=GMRCLNO+1
End DoDot:2
+104 QUIT
End DoDot:1
+105 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=""
SET GMRCLNO=GMRCLNO+1
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=IDX_" COMMENT(S): (Add Only)"
DO RVRS(GMRCLNO)
SET GMRCLNO=GMRCLNO+1
+106 IF $DATA(^TMP("GMRCED",$JOB,40))
Begin DoDot:1
+107 DO KILL^VALM10(GMRCLNO)
+108 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=" New Comment:"
SET GMRCLNO=GMRCLNO+1
+109 NEW ND
SET ND=0
FOR
SET ND=$ORDER(^TMP("GMRCED",$JOB,40,ND))
if 'ND
QUIT
Begin DoDot:2
+110 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=^TMP("GMRCED",$JOB,40,ND,0)
+111 SET GMRCLNO=GMRCLNO+1
End DoDot:2
End DoDot:1
+112 NEW GMRCEDCT
+113 SET GMRCD=0
SET GMRCEDCT=0
FOR
SET GMRCD=$ORDER(^GMR(123,+GMRCO,40,"B",GMRCD))
if 'GMRCD
QUIT
SET GMRCDD=""
SET GMRCDD=$ORDER(^GMR(123,+GMRCO,40,"B",GMRCD,GMRCDD))
if 'GMRCDD
QUIT
Begin DoDot:1
+114 IF $PIECE(^GMR(123,+GMRCO,40,GMRCDD,0),"^",2)=20
SET LN=0
SET GMRCEDCT=GMRCEDCT+1
SET GMRCEDCM(GMRCEDCT)=GMRCDD
Begin DoDot:2
+115 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=""
SET GMRCLNO=GMRCLNO+1
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)="ADDED COMMENT (Not Editable) Entered: "_$PIECE($$FMTE^XLFDT($PIECE(^GMR(123,+GMRCO,40,GMRCDD,0),"^",1)),"@",1)
+116 SET GMRCRESP=$SELECT($LENGTH($PIECE($GET(^GMR(123,+GMRCO,40,GMRCDD,0)),"^",5)):$$GET1^DIQ(200,$PIECE(^GMR(123,+GMRCO,40,GMRCDD,0),"^",5),.01),$LENGTH($PIECE($GET(^GMR(123,+GMRCO,40,GMRCDD,2)),"^",1)):...
... $PIECE(^GMR(123,+GMRCO,40,GMRCDD,2),"^",1),1:"UNKNOWN")
+117 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)_" BY: "_GMRCRESP
SET GMRCLNO=GMRCLNO+1
+118 ;S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCR",$J,"ED",GMRCLNO,0)_" BY: "_$S($L($P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",4)):$P(^VA(200,$P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",4),0),"^",1),1:"UNKNOWN"),GMRCLNO=GMRCLNO+1
+119 SET LN=$ORDER(^GMR(123,+GMRCO,40,GMRCDD,1,LN))
if LN=""!(LN?1A.E)
QUIT
IF $LENGTH(^GMR(123,+GMRCO,40,GMRCDD,1,LN,0))>75
SET FLG=1
DO WPSET^GMRCUTIL("^GMR(123,+GMRCO,40,GMRCDD,1)","^TMP(""GMRCR"",$J,""ED"")","",.GMRCLNO,"",FLG)
QUIT
+120 SET LN=0
FOR
SET LN=$ORDER(^GMR(123,+GMRCO,40,GMRCDD,1,LN))
if LN=""!(LN?1A.E)
QUIT
SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=^(LN,0)
SET GMRCLNO=GMRCLNO+1
+121 QUIT
End DoDot:2
+122 QUIT
End DoDot:1
+123 SET ^TMP("GMRCR",$JOB,"ED",GMRCLNO,0)=""
+124 KILL FLG
+125 QUIT
RVRS(LINE,EDITED) ;reverse video for fields that can be edited
+1 IF '$GET(EDITED)
DO CNTRL^VALM10(LINE,1,1,IORVON,IORVOFF)
QUIT
+2 DO CNTRL^VALM10(LINE,1,1,IORVON_IOINHI,IORVOFF_IOINORM)
+3 QUIT
