GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ;6/25/03 11:42
;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33**;DEC 27, 1997
;
; This routine invokes IA #3991
;
Q
EDITFLD(GMRCO) ;edit field in file 123.
;GMRCO=IEN of consult record in file 123
N DIR,X,Y,GMRCSS,GMRCPROC,GMRCPROC,GMRCURG,GMRCPL,GMRCREND,GMRCY,GMRCX
N GMRCMSG,GMRCTAG
I $S($P(^GMR(123,GMRCO,0),"^",12)'=13:1,$D(GMRCRSUB):1,1:0) D Q
.S GMRCMSG="This consult is no longer editable." D EXAC^GMRCADC(GMRCMSG)
S GMRCMSG=$$EDRESOK^GMRCEDT2(GMRCO)
I '+GMRCMSG D EXAC^GMRCADC($P(GMRCMSG,U,2)) Q
I $$PDOK(GMRCO)
S DIR(0)="LAO^1:8",DIR("A")="Select the fields to edit: "
D ^DIR I $D(DIRUT) Q
I $P(Y,",")<1 Q
S GMRCY=Y
F GMRCX=1:1:8 S GMRCTAG=$P(GMRCY,",",GMRCX) Q:'GMRCTAG D
. D SETUP
. D @GMRCTAG
. K DIROUT,DIRUT,DTOUT,DUOUT
. D EN^GMRCEDT1(+GMRCO),INIT^GMRCEDIT
Q
SETUP ;get info needed for edit (save global reads)
S:$D(GMRCEDT(1)) GMRCSS=GMRCEDT(1)
I '$D(GMRCSS) S GMRCSS=$P(^GMR(123,+GMRCO,0),U,5),GMRCSS=GMRCSS_U_$P(^GMR(123.5,GMRCSS,0),U)
S:$D(GMRCED(1)) GMRCPROC=GMRCED(1)
I '$D(GMRCPROC) S GMRCPROC=+$P(^GMR(123,+GMRCO,0),U,8),GMRCPROC=GMRCPROC_U_$$GET1^DIQ(123.3,+GMRCPROC,.01)
S:$D(GMRCED(2)) GMRCREND=GMRCED(2)
I '$D(GMRCREND) S GMRCREND=$P(^GMR(123,GMRCO,0),U,18),GMRCREND=GMRCREND_U_$S(GMRCREND="I":"In",1:"Out")_"patient"
S:$D(GMRCED(3)) GMRCURG=GMRCED(3)
I '$D(GMRCURG) S GMRCURG=$P(^GMR(123,+GMRCO,0),U,9),GMRCURG=GMRCURG_U_$$GET1^DIQ(101,+GMRCURG,1)
S:$D(GMRCED(4)) GMRCPL=GMRCED(4)
I '$D(GMRCPL) S GMRCPL=$P(^GMR(123,+GMRCO,0),U,10),GMRCPL=GMRCPL_U_$$GET1^DIQ(101,+GMRCPL,1)
Q
01 ;edit TO SERVICE
N I,PROCSERV,DIR,X,Y
I $G(GMRCPROC) D Q:'PROCSERV
. N I S I=0,PROCSERV=0 F S I=$O(^GMR(123.3,+GMRCPROC,2,"B",I)) Q:'I D
.. S PROCSERV(I)="",PROCSERV=PROCSERV+1
. I PROCSERV=1 W !,"Only one SERVICE can perform this procedure.",!
S DIR(0)="PA^123.5:EMQ"
I $G(PROCSERV) D
. I $D(PROCSERV(+GMRCSS)) Q
. S DIR("B")=$$GET1^DIQ(123.5,$O(PROCSERV(0)),.01)
I '$D(DIR("B")) S DIR("B")=$P(GMRCSS,U,2)
S DIR("A")="Select the Service to perform this request: "
S DIR("S")="I $P(^(0),U,2)<1"
I +$G(GMRCPROC) S DIR("S")=DIR("S")_",$D(PROCSERV(+Y))"
S DIR("??")="^D LISTALL^GMRCASV"
D ^DIR I $D(DUOUT)!($D(DTOUT)) Q
I Y<1!(+Y=+GMRCSS) W !,$$NOCHG,! Q
S GMRCEDT(1)=Y,GMRCSS=Y
Q
1 ;edit Procedure
W !,$C(7),"The procedure associated with a request may not be changed."
W !,"Place a new request if a different procedure is desired"
H 2
Q
2 ;edit service rendered
N DIR,X,Y,GMRCURSV,GMRCPLSV,GMRCED4,GMRCED5,RENDED
S DIR(0)="S:A^I:Inpatient;O:Outpatient",DIR("B")=$P(GMRCREND,U,2)
S DIR("A")="Service to be performed Inpatient or Outpatient: "
D ^DIR I $D(DUOUT)!($D(DTOUT)) W !,$$NOCHG,! Q
I Y'=$P(GMRCREND,U) S RENDED=Y_U_Y(0)
I '$D(RENDED) Q
I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D I '$D(RENDED) Q
. N GMRCREND,CHGIO S GMRCREND=RENDED
. W $C(7),!!,"The urgency of this request is no longer valid.",!
. S GMRCURSV=GMRCURG S:$D(GMRCED(3)) GMRCED3=GMRCED(3)
. S CHGREND="" D 3
. I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D Q
.. W !,$C(7),"Unable to change the way service is rendered.",!
.. K RENDED S GMRCURG=GMRCURSV S:$D(GMRCED3) GMRCED(3)=GMRCED3
I '$$VALIDPL(GMRCPL,RENDED) D I '$D(RENDED) Q
. N GMRCREND,CHGREND S GMRCREND=RENDED
. W $C(7),!!,"The Place of Consultation is no longer valid.",!
. S GMRCPLSV=GMRCPL S:$D(GMRCED(4)) GMRCED4=GMRCED(4) S CHGREND="" D 4
. I '$$VALIDPL(GMRCPL,RENDED) D Q
.. W !,$C(7),"Unable to change the way service is rendered.",!
.. K RENDED S GMRCPL=GMRCPLSV S:$D(GMRCED4) GMRCED(4)=GMRCED4
.. S:$D(GMRCURSV) GMRCURG=GMRCURSV
.. S:$D(GMRCED3) GMRCED(3)=GMRCED3
S (GMRCREND,GMRCED(2))=RENDED
Q
3 ;edit urgency
N X,Y,XQORM
I $P(GMRCREND,U)="O" S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM - OUTPATIENT")
I '$D(Y) D ;inpatient
.I '$G(GMRCPROC) S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM CSLT - INPATIENT") Q
.S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM REQ - INPATIENT")
I 'Y W !,$C(7),"Unable to change urgency." Q
S XQORM=+Y_";ORD(101,",XQORM(0)="1A\",XQORM("A")="Urgency: "
S XQORM("^^NO")=0
S:'$D(CHGREND) XQORM("B")=$P($G(GMRCURG),U,2)
D EN^XQORM
Q:Y'>0
I $P(Y(1),U,2)'=+GMRCURG D
. S GMRCED(3)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCURG=GMRCED(3)
Q
4 ;edit place of CSLT
N X,Y,XQORM
S Y=$$FIND1^DIC(101,,"QX","GMRCPLACEM - "_$$UP^XLFSTR($P(GMRCREND,U,2))) Q:'Y
S XQORM=Y_";ORD(101,"
S XQORM(0)="1AR\",XQORM("A")="Place of Consultation: ",XQORM("NO^^")=""
S:'$D(CHGREND) XQORM("B")=$P($G(GMRCPL),U,2)
D EN^XQORM
Q:Y'>0
I $P(Y(1),U,2)'=+GMRCPL D
. S GMRCED(4)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCPL=GMRCED(4)
Q
5 ;edit ATTN person
N X,Y,DIR
S DIR(0)="PAO^200:EQM",DIR("A")="Select ATTENTION person: "
S DIR("B")=$$GET1^DIQ(200,+$P(^GMR(123,+GMRCO,0),U,11),.01)
S:$D(GMRCED(5)) DIR("B")=$P($G(GMRCED(5)),U,2)
K:'$L(DIR("B")) DIR("B")
D ^DIR I $D(DTOUT)!($D(DUOUT)) Q
I $G(DIR("B"))=$P(Y,U,2) Q
S GMRCED(5)=$S(Y=-1:"",1:Y)
I GMRCED(5)="" W !,?5,"<DELETED>",!
Q
6 ;edit prov. DX
N X,Y,DIC,DIR,PRMPT
S PRMPT=$$PROVDX^GMRCUTL1(+$P(^GMR(123,+GMRCO,0),U,5))
I $P(PRMPT,U,2)="F" D
. S DIR(0)="FA^2:180",DIR("A")="Provisional Diagnosis: "
. I $P(PRMPT,U)'="R" S $P(DIR(0),U)="FAO"
. S:$D(GMRCED(6)) DIR("B")=$P(GMRCED(6),U)
. I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,+GMRCO,30))
. K:'$L(DIR("B")) DIR("B")
. D ^DIR Q:$D(DTOUT)!($D(DUOUT)) Q:Y=$G(DIR("B"))
. I '$L(Y) W !,?5,"<DELETED>",!
. S GMRCED(6)=Y
I $P(PRMPT,U,2)="L" D
. N DIR,X,Y,DTOUT,DUOUT,VAL
. I $D(GMRCED(6)) D
.. I '$L($P(GMRCED(6),U,2)) S DIR("B")=$P(GMRCED(6),U) Q
.. S DIR("B")=$P(GMRCED(6),U)_" ("_$P(GMRCED(6),U,2)_")"
. I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,GMRCO,30))
. K:'$L(DIR("B")) DIR("B")
. S DIR("?")="Enter a code or term for the provisional diagnosis."
. S DIR("A")="Provisional Diagnosis: "
. S DIR(0)="FA"_$S($P(PRMPT,U)'="R":"O",1:"")_"^1:180"
. D ^DIR
. I $D(DTOUT)!($D(DUOUT)) Q
. I '$L(Y) W !,?5,"<DELETED>",! S GMRCED(6)="" Q
. I Y=$G(DIR("B")) Q
. I $E(Y,1)=" " W !,"Leading space not allowed, no change." Q
. S VAL=$$LEXLKUP(Y)
. I '$L(VAL),$P(PRMPT,U)="R" W !,"Prov. DX required. No change." Q
. I VAL=$G(^GMR(123,GMRCO,30)) W !,"No change." Q
. I ($P(VAL,U)_" ("_$P(VAL,U,2)_")")=$G(^GMR(123,GMRCO,30)) D Q
.. W !,"No change."
. I '$L(VAL) W !,?5,"<DELETED>",!
. S GMRCED(6)=VAL
Q
;
LEXLKUP(GMRCX) ; run input through the Lexicon
;
N DIC,X,Y,DUOUT,DTOUT
D CONFIG^LEXSET("ICD","ICD",DT)
S DIC="^LEX(757.01,",DIC(0)="EQM",DIC("B")=GMRCX,X=GMRCX
D ^DIC
I $D(DTOUT)!($D(DUOUT))!($G(Y)<1) Q ""
Q $P(Y,U,2)_U_Y(1)
;
7 ;edit Reason for Request
N DIC,DIWESUB,DWLW,DWPK
I $D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCEDSV",$J,20)=^TMP("GMRCED",$J,20)
I '$D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCED",$J,20)=^GMR(123,+GMRCO,20)
S DIC="^TMP(""GMRCED"",$J,20,",DIWESUB="Reason for Request"
W !,"Editing Reason for Request:",!
S DWPK=1,DWLW=74 D EN^DIWE
I '$$DIFFRFR($D(^TMP("GMRCEDSV",$J,20))) D Q
. I $D(^TMP("GMRCEDSV",$J,20)) K ^TMP("GMRCEDSV",$J,20) Q
. K ^TMP("GMRCED",$J,20)
K ^TMP("GMRCEDSV",$J,20)
I '$D(^TMP("GMRCED",$J,20))!('$O(^TMP("GMRCED",$J,20,0))) D
. N GMRCMSG
. S GMRCMSG="Unable to delete Reason for Request (REQUIRED)"
. D EXAC^GMRCADC(GMRCMSG)
. K ^TMP("GMRCED",$J,20)
Q
8 ;add comment
N DIC,DIWEPSE,DIWESUB,DWLW,DWPK
I $D(^TMP("GMRCED",$J,40)) D
. W !,"An unsaved comment exists. You may edit this comment.",!
. S DIWEPSE=1
S DIC="^TMP(""GMRCED"",$J,40,",DIWESUB="New Comment"
W !,"Adding new comment:",!
S DWPK=1,DWLW=74 D EN^DIWE
I '$O(^TMP("GMRCED",$J,40,0)) K ^TMP("GMRCED",$J,40)
Q
DIFFRFR(SAVED) ;edited reason for req same as original?
N I,DIFF
I SAVED,$P($G(^TMP("GMRCED",$J,20,0)),U,3,4)'=$P($G(^TMP("GMRCEDSV",$J,20,0)),U,3,4) S DIFF=1 Q 1
I 'SAVED,$P($G(^TMP("GMRCED",$J,20,0)),U,3,4)'=$P($G(^GMR(123,+GMRCO,20,0)),U,3,4) S DIFF=1 Q 1
I SAVED S I=0 F S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF)) D
. I ^TMP("GMRCED",$J,20,I,0)=$G(^TMP("GMRCEDSV",$J,20,I,0)) Q
. S DIFF=1
. Q
I 'SAVED S I=0 F S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF)) D
. I ^TMP("GMRCED",$J,20,I,0)'=$G(^GMR(123,+GMRCO,20,I,0)) S DIFF=1
. Q
Q $G(DIFF)
VALIDPL(PL,REND) ; place still valid?
N PLMENU
S PLMENU=$S($P(REND,U)="I":"IN",1:"OUT")
S PLMENU="GMRCPLACEM - "_PLMENU_"PATIENT"
S PLMENU=$$FIND1^DIC(101,,"QX",PLMENU) Q:PLMENU'>1 0
Q $D(^ORD(101,PLMENU,10,"B",+PL))
VALIDUR(URG,REND,PROC) ;urgency still valid?
N URMENU
I $P(REND,U)="I" D
.I 'PROC S URMENU="GMRCURGENCYM CSLT - INPATIENT" Q
.S URMENU="GMRCURGENCYM REQ - INPATIENT" Q
I '$D(URMENU) S URMENU="GMRCURGENCYM - OUTPATIENT"
S URMENU=$$FIND1^DIC(101,,"QX",URMENU) Q:URMENU<0 0
Q $D(^ORD(101,URMENU,10,"B",+URG))
Q
NOCHG() ;no changes made
Q "No Changes made!"
PDOK(GMRCDA) ;check validity of Prov. DX code for active status
N MSG
I '$L($G(^GMR(123,GMRCDA,30.1))) Q 1
I +$$STATCHK^ICDAPIU(^GMR(123,GMRCDA,30.1),DT) Q 1 ;code still active
S MSG="The provisional DX code must be edited before this request"
S MSG=MSG_" may be resubmitted."
D EN^DDIOL(MSG,,"!!")
Q 0
GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ;6/25/03 11:42
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33**;DEC 27, 1997
+2 ;
+3 ; This routine invokes IA #3991
+4 ;
+5 QUIT
EDITFLD(GMRCO) ;edit field in file 123.
+1 ;GMRCO=IEN of consult record in file 123
+2 NEW DIR,X,Y,GMRCSS,GMRCPROC,GMRCPROC,GMRCURG,GMRCPL,GMRCREND,GMRCY,GMRCX
+3 NEW GMRCMSG,GMRCTAG
+4 IF $SELECT($PIECE(^GMR(123,GMRCO,0),"^",12)'=13:1,$DATA(GMRCRSUB):1,1:0)
Begin DoDot:1
+5 SET GMRCMSG="This consult is no longer editable."
DO EXAC^GMRCADC(GMRCMSG)
End DoDot:1
QUIT
+6 SET GMRCMSG=$$EDRESOK^GMRCEDT2(GMRCO)
+7 IF '+GMRCMSG
DO EXAC^GMRCADC($PIECE(GMRCMSG,U,2))
QUIT
+8 IF $$PDOK(GMRCO)
+9 SET DIR(0)="LAO^1:8"
SET DIR("A")="Select the fields to edit: "
+10 DO ^DIR
IF $DATA(DIRUT)
QUIT
+11 IF $PIECE(Y,",")<1
QUIT
+12 SET GMRCY=Y
+13 FOR GMRCX=1:1:8
SET GMRCTAG=$PIECE(GMRCY,",",GMRCX)
IF 'GMRCTAG
QUIT
Begin DoDot:1
+14 DO SETUP
+15 DO @GMRCTAG
+16 KILL DIROUT,DIRUT,DTOUT,DUOUT
+17 DO EN^GMRCEDT1(+GMRCO)
DO INIT^GMRCEDIT
End DoDot:1
+18 QUIT
SETUP ;get info needed for edit (save global reads)
+1 IF $DATA(GMRCEDT(1))
SET GMRCSS=GMRCEDT(1)
+2 IF '$DATA(GMRCSS)
SET GMRCSS=$PIECE(^GMR(123,+GMRCO,0),U,5)
SET GMRCSS=GMRCSS_U_$PIECE(^GMR(123.5,GMRCSS,0),U)
+3 IF $DATA(GMRCED(1))
SET GMRCPROC=GMRCED(1)
+4 IF '$DATA(GMRCPROC)
SET GMRCPROC=+$PIECE(^GMR(123,+GMRCO,0),U,8)
SET GMRCPROC=GMRCPROC_U_$$GET1^DIQ(123.3,+GMRCPROC,.01)
+5 IF $DATA(GMRCED(2))
SET GMRCREND=GMRCED(2)
+6 IF '$DATA(GMRCREND)
SET GMRCREND=$PIECE(^GMR(123,GMRCO,0),U,18)
SET GMRCREND=GMRCREND_U_$SELECT(GMRCREND="I":"In",1:"Out")_"patient"
+7 IF $DATA(GMRCED(3))
SET GMRCURG=GMRCED(3)
+8 IF '$DATA(GMRCURG)
SET GMRCURG=$PIECE(^GMR(123,+GMRCO,0),U,9)
SET GMRCURG=GMRCURG_U_$$GET1^DIQ(101,+GMRCURG,1)
+9 IF $DATA(GMRCED(4))
SET GMRCPL=GMRCED(4)
+10 IF '$DATA(GMRCPL)
SET GMRCPL=$PIECE(^GMR(123,+GMRCO,0),U,10)
SET GMRCPL=GMRCPL_U_$$GET1^DIQ(101,+GMRCPL,1)
+11 QUIT
01 ;edit TO SERVICE
+1 NEW I,PROCSERV,DIR,X,Y
+2 IF $GET(GMRCPROC)
Begin DoDot:1
+3 NEW I
SET I=0
SET PROCSERV=0
FOR
SET I=$ORDER(^GMR(123.3,+GMRCPROC,2,"B",I))
IF 'I
QUIT
Begin DoDot:2
+4 SET PROCSERV(I)=""
SET PROCSERV=PROCSERV+1
End DoDot:2
+5 IF PROCSERV=1
WRITE !,"Only one SERVICE can perform this procedure.",!
End DoDot:1
IF 'PROCSERV
QUIT
+6 SET DIR(0)="PA^123.5:EMQ"
+7 IF $GET(PROCSERV)
Begin DoDot:1
+8 IF $DATA(PROCSERV(+GMRCSS))
QUIT
+9 SET DIR("B")=$$GET1^DIQ(123.5,$ORDER(PROCSERV(0)),.01)
End DoDot:1
+10 IF '$DATA(DIR("B"))
SET DIR("B")=$PIECE(GMRCSS,U,2)
+11 SET DIR("A")="Select the Service to perform this request: "
+12 SET DIR("S")="I $P(^(0),U,2)<1"
+13 IF +$GET(GMRCPROC)
SET DIR("S")=DIR("S")_",$D(PROCSERV(+Y))"
+14 SET DIR("??")="^D LISTALL^GMRCASV"
+15 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+16 IF Y<1!(+Y=+GMRCSS)
WRITE !,$$NOCHG,!
QUIT
+17 SET GMRCEDT(1)=Y
SET GMRCSS=Y
+18 QUIT
1 ;edit Procedure
+1 WRITE !,$CHAR(7),"The procedure associated with a request may not be changed."
+2 WRITE !,"Place a new request if a different procedure is desired"
+3 HANG 2
+4 QUIT
2 ;edit service rendered
+1 NEW DIR,X,Y,GMRCURSV,GMRCPLSV,GMRCED4,GMRCED5,RENDED
+2 SET DIR(0)="S:A^I:Inpatient;O:Outpatient"
SET DIR("B")=$PIECE(GMRCREND,U,2)
+3 SET DIR("A")="Service to be performed Inpatient or Outpatient: "
+4 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
WRITE !,$$NOCHG,!
QUIT
+5 IF Y'=$PIECE(GMRCREND,U)
SET RENDED=Y_U_Y(0)
+6 IF '$DATA(RENDED)
QUIT
+7 IF '$$VALIDUR(GMRCURG,RENDED,+$GET(GMRCPROC))
Begin DoDot:1
+8 NEW GMRCREND,CHGIO
SET GMRCREND=RENDED
+9 WRITE $CHAR(7),!!,"The urgency of this request is no longer valid.",!
+10 SET GMRCURSV=GMRCURG
IF $DATA(GMRCED(3))
SET GMRCED3=GMRCED(3)
+11 SET CHGREND=""
DO 3
+12 IF '$$VALIDUR(GMRCURG,RENDED,+$GET(GMRCPROC))
Begin DoDot:2
+13 WRITE !,$CHAR(7),"Unable to change the way service is rendered.",!
+14 KILL RENDED
SET GMRCURG=GMRCURSV
IF $DATA(GMRCED3)
SET GMRCED(3)=GMRCED3
End DoDot:2
QUIT
End DoDot:1
IF '$DATA(RENDED)
QUIT
+15 IF '$$VALIDPL(GMRCPL,RENDED)
Begin DoDot:1
+16 NEW GMRCREND,CHGREND
SET GMRCREND=RENDED
+17 WRITE $CHAR(7),!!,"The Place of Consultation is no longer valid.",!
+18 SET GMRCPLSV=GMRCPL
IF $DATA(GMRCED(4))
SET GMRCED4=GMRCED(4)
SET CHGREND=""
DO 4
+19 IF '$$VALIDPL(GMRCPL,RENDED)
Begin DoDot:2
+20 WRITE !,$CHAR(7),"Unable to change the way service is rendered.",!
+21 KILL RENDED
SET GMRCPL=GMRCPLSV
IF $DATA(GMRCED4)
SET GMRCED(4)=GMRCED4
+22 IF $DATA(GMRCURSV)
SET GMRCURG=GMRCURSV
+23 IF $DATA(GMRCED3)
SET GMRCED(3)=GMRCED3
End DoDot:2
QUIT
End DoDot:1
IF '$DATA(RENDED)
QUIT
+24 SET (GMRCREND,GMRCED(2))=RENDED
+25 QUIT
3 ;edit urgency
+1 NEW X,Y,XQORM
+2 IF $PIECE(GMRCREND,U)="O"
SET Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM - OUTPATIENT")
+3 ;inpatient
IF '$DATA(Y)
Begin DoDot:1
+4 IF '$GET(GMRCPROC)
SET Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM CSLT - INPATIENT")
QUIT
+5 SET Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM REQ - INPATIENT")
End DoDot:1
+6 IF 'Y
WRITE !,$CHAR(7),"Unable to change urgency."
QUIT
+7 SET XQORM=+Y_";ORD(101,"
SET XQORM(0)="1A\"
SET XQORM("A")="Urgency: "
+8 SET XQORM("^^NO")=0
+9 IF '$DATA(CHGREND)
SET XQORM("B")=$PIECE($GET(GMRCURG),U,2)
+10 DO EN^XQORM
+11 IF Y'>0
QUIT
+12 IF $PIECE(Y(1),U,2)'=+GMRCURG
Begin DoDot:1
+13 SET GMRCED(3)=$PIECE(Y(1),U,2)_U_$PIECE(Y(1),U,3)
SET GMRCURG=GMRCED(3)
End DoDot:1
+14 QUIT
4 ;edit place of CSLT
+1 NEW X,Y,XQORM
+2 SET Y=$$FIND1^DIC(101,,"QX","GMRCPLACEM - "_$$UP^XLFSTR($PIECE(GMRCREND,U,2)))
IF 'Y
QUIT
+3 SET XQORM=Y_";ORD(101,"
+4 SET XQORM(0)="1AR\"
SET XQORM("A")="Place of Consultation: "
SET XQORM("NO^^")=""
+5 IF '$DATA(CHGREND)
SET XQORM("B")=$PIECE($GET(GMRCPL),U,2)
+6 DO EN^XQORM
+7 IF Y'>0
QUIT
+8 IF $PIECE(Y(1),U,2)'=+GMRCPL
Begin DoDot:1
+9 SET GMRCED(4)=$PIECE(Y(1),U,2)_U_$PIECE(Y(1),U,3)
SET GMRCPL=GMRCED(4)
End DoDot:1
+10 QUIT
5 ;edit ATTN person
+1 NEW X,Y,DIR
+2 SET DIR(0)="PAO^200:EQM"
SET DIR("A")="Select ATTENTION person: "
+3 SET DIR("B")=$$GET1^DIQ(200,+$PIECE(^GMR(123,+GMRCO,0),U,11),.01)
+4 IF $DATA(GMRCED(5))
SET DIR("B")=$PIECE($GET(GMRCED(5)),U,2)
+5 IF '$LENGTH(DIR("B"))
KILL DIR("B")
+6 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+7 IF $GET(DIR("B"))=$PIECE(Y,U,2)
QUIT
+8 SET GMRCED(5)=$SELECT(Y=-1:"",1:Y)
+9 IF GMRCED(5)=""
WRITE !,?5,"<DELETED>",!
+10 QUIT
6 ;edit prov. DX
+1 NEW X,Y,DIC,DIR,PRMPT
+2 SET PRMPT=$$PROVDX^GMRCUTL1(+$PIECE(^GMR(123,+GMRCO,0),U,5))
+3 IF $PIECE(PRMPT,U,2)="F"
Begin DoDot:1
+4 SET DIR(0)="FA^2:180"
SET DIR("A")="Provisional Diagnosis: "
+5 IF $PIECE(PRMPT,U)'="R"
SET $PIECE(DIR(0),U)="FAO"
+6 IF $DATA(GMRCED(6))
SET DIR("B")=$PIECE(GMRCED(6),U)
+7 IF '$DATA(DIR("B"))
SET DIR("B")=$GET(^GMR(123,+GMRCO,30))
+8 IF '$LENGTH(DIR("B"))
KILL DIR("B")
+9 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
IF Y=$GET(DIR("B"))
QUIT
+10 IF '$LENGTH(Y)
WRITE !,?5,"<DELETED>",!
+11 SET GMRCED(6)=Y
End DoDot:1
+12 IF $PIECE(PRMPT,U,2)="L"
Begin DoDot:1
+13 NEW DIR,X,Y,DTOUT,DUOUT,VAL
+14 IF $DATA(GMRCED(6))
Begin DoDot:2
+15 IF '$LENGTH($PIECE(GMRCED(6),U,2))
SET DIR("B")=$PIECE(GMRCED(6),U)
QUIT
+16 SET DIR("B")=$PIECE(GMRCED(6),U)_" ("_$PIECE(GMRCED(6),U,2)_")"
End DoDot:2
+17 IF '$DATA(DIR("B"))
SET DIR("B")=$GET(^GMR(123,GMRCO,30))
+18 IF '$LENGTH(DIR("B"))
KILL DIR("B")
+19 SET DIR("?")="Enter a code or term for the provisional diagnosis."
+20 SET DIR("A")="Provisional Diagnosis: "
+21 SET DIR(0)="FA"_$SELECT($PIECE(PRMPT,U)'="R":"O",1:"")_"^1:180"
+22 DO ^DIR
+23 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+24 IF '$LENGTH(Y)
WRITE !,?5,"<DELETED>",!
SET GMRCED(6)=""
QUIT
+25 IF Y=$GET(DIR("B"))
QUIT
+26 IF $EXTRACT(Y,1)=" "
WRITE !,"Leading space not allowed, no change."
QUIT
+27 SET VAL=$$LEXLKUP(Y)
+28 IF '$LENGTH(VAL)
IF $PIECE(PRMPT,U)="R"
WRITE !,"Prov. DX required. No change."
QUIT
+29 IF VAL=$GET(^GMR(123,GMRCO,30))
WRITE !,"No change."
QUIT
+30 IF ($PIECE(VAL,U)_" ("_$PIECE(VAL,U,2)_")")=$GET(^GMR(123,GMRCO,30))
Begin DoDot:2
+31 WRITE !,"No change."
End DoDot:2
QUIT
+32 IF '$LENGTH(VAL)
WRITE !,?5,"<DELETED>",!
+33 SET GMRCED(6)=VAL
End DoDot:1
+34 QUIT
+35 ;
LEXLKUP(GMRCX) ; run input through the Lexicon
+1 ;
+2 NEW DIC,X,Y,DUOUT,DTOUT
+3 DO CONFIG^LEXSET("ICD","ICD",DT)
+4 SET DIC="^LEX(757.01,"
SET DIC(0)="EQM"
SET DIC("B")=GMRCX
SET X=GMRCX
+5 DO ^DIC
+6 IF $DATA(DTOUT)!($DATA(DUOUT))!($GET(Y)<1)
QUIT ""
+7 QUIT $PIECE(Y,U,2)_U_Y(1)
+8 ;
7 ;edit Reason for Request
+1 NEW DIC,DIWESUB,DWLW,DWPK
+2 IF $DATA(^TMP("GMRCED",$JOB,20))
MERGE ^TMP("GMRCEDSV",$JOB,20)=^TMP("GMRCED",$JOB,20)
+3 IF '$DATA(^TMP("GMRCED",$JOB,20))
MERGE ^TMP("GMRCED",$JOB,20)=^GMR(123,+GMRCO,20)
+4 SET DIC="^TMP(""GMRCED"",$J,20,"
SET DIWESUB="Reason for Request"
+5 WRITE !,"Editing Reason for Request:",!
+6 SET DWPK=1
SET DWLW=74
DO EN^DIWE
+7 IF '$$DIFFRFR($DATA(^TMP("GMRCEDSV",$JOB,20)))
Begin DoDot:1
+8 IF $DATA(^TMP("GMRCEDSV",$JOB,20))
KILL ^TMP("GMRCEDSV",$JOB,20)
QUIT
+9 KILL ^TMP("GMRCED",$JOB,20)
End DoDot:1
QUIT
+10 KILL ^TMP("GMRCEDSV",$JOB,20)
+11 IF '$DATA(^TMP("GMRCED",$JOB,20))!('$ORDER(^TMP("GMRCED",$JOB,20,0)))
Begin DoDot:1
+12 NEW GMRCMSG
+13 SET GMRCMSG="Unable to delete Reason for Request (REQUIRED)"
+14 DO EXAC^GMRCADC(GMRCMSG)
+15 KILL ^TMP("GMRCED",$JOB,20)
End DoDot:1
+16 QUIT
8 ;add comment
+1 NEW DIC,DIWEPSE,DIWESUB,DWLW,DWPK
+2 IF $DATA(^TMP("GMRCED",$JOB,40))
Begin DoDot:1
+3 WRITE !,"An unsaved comment exists. You may edit this comment.",!
+4 SET DIWEPSE=1
End DoDot:1
+5 SET DIC="^TMP(""GMRCED"",$J,40,"
SET DIWESUB="New Comment"
+6 WRITE !,"Adding new comment:",!
+7 SET DWPK=1
SET DWLW=74
DO EN^DIWE
+8 IF '$ORDER(^TMP("GMRCED",$JOB,40,0))
KILL ^TMP("GMRCED",$JOB,40)
+9 QUIT
DIFFRFR(SAVED) ;edited reason for req same as original?
+1 NEW I,DIFF
+2 IF SAVED
IF $PIECE($GET(^TMP("GMRCED",$JOB,20,0)),U,3,4)'=$PIECE($GET(^TMP("GMRCEDSV",$JOB,20,0)),U,3,4)
SET DIFF=1
QUIT 1
+3 IF 'SAVED
IF $PIECE($GET(^TMP("GMRCED",$JOB,20,0)),U,3,4)'=$PIECE($GET(^GMR(123,+GMRCO,20,0)),U,3,4)
SET DIFF=1
QUIT 1
+4 IF SAVED
SET I=0
FOR
SET I=$ORDER(^TMP("GMRCED",$JOB,20,I))
IF 'I!($DATA(DIFF))
QUIT
Begin DoDot:1
+5 IF ^TMP("GMRCED",$JOB,20,I,0)=$GET(^TMP("GMRCEDSV",$JOB,20,I,0))
QUIT
+6 SET DIFF=1
+7 QUIT
End DoDot:1
+8 IF 'SAVED
SET I=0
FOR
SET I=$ORDER(^TMP("GMRCED",$JOB,20,I))
IF 'I!($DATA(DIFF))
QUIT
Begin DoDot:1
+9 IF ^TMP("GMRCED",$JOB,20,I,0)'=$GET(^GMR(123,+GMRCO,20,I,0))
SET DIFF=1
+10 QUIT
End DoDot:1
+11 QUIT $GET(DIFF)
VALIDPL(PL,REND) ; place still valid?
+1 NEW PLMENU
+2 SET PLMENU=$SELECT($PIECE(REND,U)="I":"IN",1:"OUT")
+3 SET PLMENU="GMRCPLACEM - "_PLMENU_"PATIENT"
+4 SET PLMENU=$$FIND1^DIC(101,,"QX",PLMENU)
IF PLMENU'>1
QUIT 0
+5 QUIT $DATA(^ORD(101,PLMENU,10,"B",+PL))
VALIDUR(URG,REND,PROC) ;urgency still valid?
+1 NEW URMENU
+2 IF $PIECE(REND,U)="I"
Begin DoDot:1
+3 IF 'PROC
SET URMENU="GMRCURGENCYM CSLT - INPATIENT"
QUIT
+4 SET URMENU="GMRCURGENCYM REQ - INPATIENT"
QUIT
End DoDot:1
+5 IF '$DATA(URMENU)
SET URMENU="GMRCURGENCYM - OUTPATIENT"
+6 SET URMENU=$$FIND1^DIC(101,,"QX",URMENU)
IF URMENU<0
QUIT 0
+7 QUIT $DATA(^ORD(101,URMENU,10,"B",+URG))
+8 QUIT
NOCHG() ;no changes made
+1 QUIT "No Changes made!"
PDOK(GMRCDA) ;check validity of Prov. DX code for active status
+1 NEW MSG
+2 IF '$LENGTH($GET(^GMR(123,GMRCDA,30.1)))
QUIT 1
+3 ;code still active
IF +$$STATCHK^ICDAPIU(^GMR(123,GMRCDA,30.1),DT)
QUIT 1
+4 SET MSG="The provisional DX code must be edited before this request"
+5 SET MSG=MSG_" may be resubmitted."
+6 DO EN^DDIOL(MSG,,"!!")
+7 QUIT 0
