- GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ;10/14/15 11:51
- ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,66,73,85,81**;DEC 27, 1997;Build 6
- ;
- ; This routine invokes IA #5747 (ICDEX), #872 (ORD(101)), #10142 (DDIOL), #10006 (DIC)
- ; #2051 (FIND1^DIC), #2056 (GET1^DIQ), #10026 (DIR), #10028 (DIWE), #5679 (LEXU)
- ; #1572 (LEX(757.01), #1609 (CONFIG^LEXSET), #10103 (XLFDT), #10104 (XLFSTR), #10140 (XQORM)
- ;
- 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
- ;patch 85 removed call to $$PDOK(GMRCO)
- S DIR(0)="LAO^1:9",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:9 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" ;naked reference for ^GMR(123.5
- 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 Clinically Ind. Date wat/66/81
- N X,Y,DIR
- S DIR(0)="D^^K:Y<DT X",DIR("A")="Clinically Indicated Date: " ;S DIR(0)="D^DT:GMRCFTDT:EX"
- S DIR("?")="Enter a date greater than or equal to TODAY"
- S DIR("B")=$$FMTE^XLFDT(DT)
- D ^DIR I $D(DTOUT)!($D(DUOUT)) Q
- S GMRCED(5)=Y_U_Y(0)
- Q
- 6 ;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(6)) DIR("B")=$P($G(GMRCED(6)),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(6)=$S(Y=-1:"",1:Y)
- I GMRCED(6)="" W !,?5,"<DELETED>",!
- Q
- 7 ;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:245",DIR("A")="Provisional Diagnosis: "
- . I $P(PRMPT,U)'="R" S $P(DIR(0),U)="FAO"
- . S:$D(GMRCED(7)) DIR("B")=$P(GMRCED(7),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(7)=Y
- I $P(PRMPT,U,2)="L" D
- . N DIR,X,Y,DTOUT,DUOUT,VAL
- . I $D(GMRCED(7)) D
- .. I '$L($P(GMRCED(7),U,2)) S DIR("B")=$P(GMRCED(7),U) Q
- .. S DIR("B")=$P(GMRCED(7),U)_" ("_$P(GMRCED(7),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:245"
- . D ^DIR
- . I $D(DTOUT)!($D(DUOUT)) Q
- . I '$L(Y) W !,?5,"<DELETED>",! S GMRCED(7)="" 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(7)=VAL
- Q
- ;
- LEXLKUP(GMRCX) ; run input through the Lexicon
- ;
- N DIC,X,Y,DUOUT,DTOUT,GMRCSYS
- S GMRCSYS="ICD" I DT>=$$IMPDATE^LEXU("10D") S GMRCSYS="10D"
- D CONFIG^LEXSET(GMRCSYS,GMRCSYS,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_$S(GMRCSYS="ICD":$G(Y(1)),1:$G(Y(30)))
- ;
- 8 ;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
- 9 ;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
- ;WAT - as of patch 85 this code no longer called. Leaving here in case biz needs change.
- N MSG,GMRCCPTR,GMRCCSYS,GMRCCODE
- I '$L($G(^GMR(123,GMRCDA,30.1))) Q 1
- S GMRCCODE=$P($G(^GMR(123,+GMRCO,30.1)),"^",1)
- S GMRCCSYS=$P($G(^GMR(123,+GMRCO,30.1)),"^",3)
- S GMRCCPTR=$S(GMRCCSYS="ICD":1,1:30)
- I +$$STATCHK^ICDEX(GMRCCODE,DT,GMRCCPTR) 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCEDT4 10270 printed Jan 18, 2025@02:46:48 Page 2
- GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ;10/14/15 11:51
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,66,73,85,81**;DEC 27, 1997;Build 6
- +2 ;
- +3 ; This routine invokes IA #5747 (ICDEX), #872 (ORD(101)), #10142 (DDIOL), #10006 (DIC)
- +4 ; #2051 (FIND1^DIC), #2056 (GET1^DIQ), #10026 (DIR), #10028 (DIWE), #5679 (LEXU)
- +5 ; #1572 (LEX(757.01), #1609 (CONFIG^LEXSET), #10103 (XLFDT), #10104 (XLFSTR), #10140 (XQORM)
- +6 ;
- +7 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 ;patch 85 removed call to $$PDOK(GMRCO)
- +9 SET DIR(0)="LAO^1:9"
- 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:9
- 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 ;naked reference for ^GMR(123.5
- 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 Clinically Ind. Date wat/66/81
- +1 NEW X,Y,DIR
- +2 ;S DIR(0)="D^DT:GMRCFTDT:EX"
- SET DIR(0)="D^^K:Y<DT X"
- SET DIR("A")="Clinically Indicated Date: "
- +3 SET DIR("?")="Enter a date greater than or equal to TODAY"
- +4 SET DIR("B")=$$FMTE^XLFDT(DT)
- +5 DO ^DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +6 SET GMRCED(5)=Y_U_Y(0)
- +7 QUIT
- 6 ;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(6))
- SET DIR("B")=$PIECE($GET(GMRCED(6)),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(6)=$SELECT(Y=-1:"",1:Y)
- +9 IF GMRCED(6)=""
- WRITE !,?5,"<DELETED>",!
- +10 QUIT
- 7 ;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:245"
- SET DIR("A")="Provisional Diagnosis: "
- +5 IF $PIECE(PRMPT,U)'="R"
- SET $PIECE(DIR(0),U)="FAO"
- +6 if $DATA(GMRCED(7))
- SET DIR("B")=$PIECE(GMRCED(7),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(7)=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(7))
- Begin DoDot:2
- +15 IF '$LENGTH($PIECE(GMRCED(7),U,2))
- SET DIR("B")=$PIECE(GMRCED(7),U)
- QUIT
- +16 SET DIR("B")=$PIECE(GMRCED(7),U)_" ("_$PIECE(GMRCED(7),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:245"
- +22 DO ^DIR
- +23 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +24 IF '$LENGTH(Y)
- WRITE !,?5,"<DELETED>",!
- SET GMRCED(7)=""
- 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(7)=VAL
- End DoDot:1
- +34 QUIT
- +35 ;
- LEXLKUP(GMRCX) ; run input through the Lexicon
- +1 ;
- +2 NEW DIC,X,Y,DUOUT,DTOUT,GMRCSYS
- +3 SET GMRCSYS="ICD"
- IF DT>=$$IMPDATE^LEXU("10D")
- SET GMRCSYS="10D"
- +4 DO CONFIG^LEXSET(GMRCSYS,GMRCSYS,DT)
- +5 SET DIC="^LEX(757.01,"
- SET DIC(0)="EQM"
- SET DIC("B")=GMRCX
- SET X=GMRCX
- +6 DO ^DIC
- +7 IF $DATA(DTOUT)!($DATA(DUOUT))!($GET(Y)<1)
- QUIT ""
- +8 QUIT $PIECE(Y,U,2)_U_$SELECT(GMRCSYS="ICD":$GET(Y(1)),1:$GET(Y(30)))
- +9 ;
- 8 ;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
- 9 ;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 ;WAT - as of patch 85 this code no longer called. Leaving here in case biz needs change.
- +2 NEW MSG,GMRCCPTR,GMRCCSYS,GMRCCODE
- +3 IF '$LENGTH($GET(^GMR(123,GMRCDA,30.1)))
- QUIT 1
- +4 SET GMRCCODE=$PIECE($GET(^GMR(123,+GMRCO,30.1)),"^",1)
- +5 SET GMRCCSYS=$PIECE($GET(^GMR(123,+GMRCO,30.1)),"^",3)
- +6 SET GMRCCPTR=$SELECT(GMRCCSYS="ICD":1,1:30)
- +7 ;code still active
- IF +$$STATCHK^ICDEX(GMRCCODE,DT,GMRCCPTR)
- QUIT 1
- +8 SET MSG="The provisional DX code must be edited before this request"
- +9 SET MSG=MSG_" may be resubmitted."
- +10 DO EN^DDIOL(MSG,,"!!")
- +11 QUIT 0