Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCEDT4

GMRCEDT4.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; This routine invokes IA #5747 (ICDEX), #872 (ORD(101)), #10142 (DDIOL), #10006 (DIC)
  1. ; #2051 (FIND1^DIC), #2056 (GET1^DIQ), #10026 (DIR), #10028 (DIWE), #5679 (LEXU)
  1. ; #1572 (LEX(757.01), #1609 (CONFIG^LEXSET), #10103 (XLFDT), #10104 (XLFSTR), #10140 (XQORM)
  1. ;
  1. Q
  1. EDITFLD(GMRCO) ;edit field in file 123.
  1. ;GMRCO=IEN of consult record in file 123
  1. N DIR,X,Y,GMRCSS,GMRCPROC,GMRCPROC,GMRCURG,GMRCPL,GMRCREND,GMRCY,GMRCX
  1. N GMRCMSG,GMRCTAG
  1. I $S($P(^GMR(123,GMRCO,0),"^",12)'=13:1,$D(GMRCRSUB):1,1:0) D Q
  1. .S GMRCMSG="This consult is no longer editable." D EXAC^GMRCADC(GMRCMSG)
  1. S GMRCMSG=$$EDRESOK^GMRCEDT2(GMRCO)
  1. I '+GMRCMSG D EXAC^GMRCADC($P(GMRCMSG,U,2)) Q
  1. ;patch 85 removed call to $$PDOK(GMRCO)
  1. S DIR(0)="LAO^1:9",DIR("A")="Select the fields to edit: "
  1. D ^DIR I $D(DIRUT) Q
  1. I $P(Y,",")<1 Q
  1. S GMRCY=Y
  1. F GMRCX=1:1:9 S GMRCTAG=$P(GMRCY,",",GMRCX) Q:'GMRCTAG D
  1. . D SETUP
  1. . D @GMRCTAG
  1. . K DIROUT,DIRUT,DTOUT,DUOUT
  1. . D EN^GMRCEDT1(+GMRCO),INIT^GMRCEDIT
  1. Q
  1. SETUP ;get info needed for edit (save global reads)
  1. S:$D(GMRCEDT(1)) GMRCSS=GMRCEDT(1)
  1. I '$D(GMRCSS) S GMRCSS=$P(^GMR(123,+GMRCO,0),U,5),GMRCSS=GMRCSS_U_$P(^GMR(123.5,GMRCSS,0),U)
  1. S:$D(GMRCED(1)) GMRCPROC=GMRCED(1)
  1. I '$D(GMRCPROC) S GMRCPROC=+$P(^GMR(123,+GMRCO,0),U,8),GMRCPROC=GMRCPROC_U_$$GET1^DIQ(123.3,+GMRCPROC,.01)
  1. S:$D(GMRCED(2)) GMRCREND=GMRCED(2)
  1. I '$D(GMRCREND) S GMRCREND=$P(^GMR(123,GMRCO,0),U,18),GMRCREND=GMRCREND_U_$S(GMRCREND="I":"In",1:"Out")_"patient"
  1. S:$D(GMRCED(3)) GMRCURG=GMRCED(3)
  1. I '$D(GMRCURG) S GMRCURG=$P(^GMR(123,+GMRCO,0),U,9),GMRCURG=GMRCURG_U_$$GET1^DIQ(101,+GMRCURG,1)
  1. S:$D(GMRCED(4)) GMRCPL=GMRCED(4)
  1. I '$D(GMRCPL) S GMRCPL=$P(^GMR(123,+GMRCO,0),U,10),GMRCPL=GMRCPL_U_$$GET1^DIQ(101,+GMRCPL,1)
  1. Q
  1. 01 ;edit TO SERVICE
  1. N I,PROCSERV,DIR,X,Y
  1. I $G(GMRCPROC) D Q:'PROCSERV
  1. . N I S I=0,PROCSERV=0 F S I=$O(^GMR(123.3,+GMRCPROC,2,"B",I)) Q:'I D
  1. .. S PROCSERV(I)="",PROCSERV=PROCSERV+1
  1. . I PROCSERV=1 W !,"Only one SERVICE can perform this procedure.",!
  1. S DIR(0)="PA^123.5:EMQ"
  1. I $G(PROCSERV) D
  1. . I $D(PROCSERV(+GMRCSS)) Q
  1. . S DIR("B")=$$GET1^DIQ(123.5,$O(PROCSERV(0)),.01)
  1. I '$D(DIR("B")) S DIR("B")=$P(GMRCSS,U,2)
  1. S DIR("A")="Select the Service to perform this request: "
  1. S DIR("S")="I $P(^(0),U,2)<1" ;naked reference for ^GMR(123.5
  1. I +$G(GMRCPROC) S DIR("S")=DIR("S")_",$D(PROCSERV(+Y))"
  1. S DIR("??")="^D LISTALL^GMRCASV"
  1. D ^DIR I $D(DUOUT)!($D(DTOUT)) Q
  1. I Y<1!(+Y=+GMRCSS) W !,$$NOCHG,! Q
  1. S GMRCEDT(1)=Y,GMRCSS=Y
  1. Q
  1. 1 ;edit Procedure
  1. W !,$C(7),"The procedure associated with a request may not be changed."
  1. W !,"Place a new request if a different procedure is desired"
  1. H 2
  1. Q
  1. 2 ;edit service rendered
  1. N DIR,X,Y,GMRCURSV,GMRCPLSV,GMRCED4,GMRCED5,RENDED
  1. S DIR(0)="S:A^I:Inpatient;O:Outpatient",DIR("B")=$P(GMRCREND,U,2)
  1. S DIR("A")="Service to be performed Inpatient or Outpatient: "
  1. D ^DIR I $D(DUOUT)!($D(DTOUT)) W !,$$NOCHG,! Q
  1. I Y'=$P(GMRCREND,U) S RENDED=Y_U_Y(0)
  1. I '$D(RENDED) Q
  1. I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D I '$D(RENDED) Q
  1. . N GMRCREND,CHGIO S GMRCREND=RENDED
  1. . W $C(7),!!,"The urgency of this request is no longer valid.",!
  1. . S GMRCURSV=GMRCURG S:$D(GMRCED(3)) GMRCED3=GMRCED(3)
  1. . S CHGREND="" D 3
  1. . I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D Q
  1. .. W !,$C(7),"Unable to change the way service is rendered.",!
  1. .. K RENDED S GMRCURG=GMRCURSV S:$D(GMRCED3) GMRCED(3)=GMRCED3
  1. I '$$VALIDPL(GMRCPL,RENDED) D I '$D(RENDED) Q
  1. . N GMRCREND,CHGREND S GMRCREND=RENDED
  1. . W $C(7),!!,"The Place of Consultation is no longer valid.",!
  1. . S GMRCPLSV=GMRCPL S:$D(GMRCED(4)) GMRCED4=GMRCED(4) S CHGREND="" D 4
  1. . I '$$VALIDPL(GMRCPL,RENDED) D Q
  1. .. W !,$C(7),"Unable to change the way service is rendered.",!
  1. .. K RENDED S GMRCPL=GMRCPLSV S:$D(GMRCED4) GMRCED(4)=GMRCED4
  1. .. S:$D(GMRCURSV) GMRCURG=GMRCURSV
  1. .. S:$D(GMRCED3) GMRCED(3)=GMRCED3
  1. S (GMRCREND,GMRCED(2))=RENDED
  1. Q
  1. 3 ;edit urgency
  1. N X,Y,XQORM
  1. I $P(GMRCREND,U)="O" S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM - OUTPATIENT")
  1. I '$D(Y) D ;inpatient
  1. .I '$G(GMRCPROC) S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM CSLT - INPATIENT") Q
  1. .S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM REQ - INPATIENT")
  1. I 'Y W !,$C(7),"Unable to change urgency." Q
  1. S XQORM=+Y_";ORD(101,",XQORM(0)="1A\",XQORM("A")="Urgency: "
  1. S XQORM("^^NO")=0
  1. S:'$D(CHGREND) XQORM("B")=$P($G(GMRCURG),U,2)
  1. D EN^XQORM
  1. Q:Y'>0
  1. I $P(Y(1),U,2)'=+GMRCURG D
  1. . S GMRCED(3)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCURG=GMRCED(3)
  1. Q
  1. 4 ;edit place of CSLT
  1. N X,Y,XQORM
  1. S Y=$$FIND1^DIC(101,,"QX","GMRCPLACEM - "_$$UP^XLFSTR($P(GMRCREND,U,2))) Q:'Y
  1. S XQORM=Y_";ORD(101,"
  1. S XQORM(0)="1AR\",XQORM("A")="Place of Consultation: ",XQORM("NO^^")=""
  1. S:'$D(CHGREND) XQORM("B")=$P($G(GMRCPL),U,2)
  1. D EN^XQORM
  1. Q:Y'>0
  1. I $P(Y(1),U,2)'=+GMRCPL D
  1. . S GMRCED(4)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCPL=GMRCED(4)
  1. Q
  1. 5 ;edit Clinically Ind. Date wat/66/81
  1. N X,Y,DIR
  1. S DIR(0)="D^^K:Y<DT X",DIR("A")="Clinically Indicated Date: " ;S DIR(0)="D^DT:GMRCFTDT:EX"
  1. S DIR("?")="Enter a date greater than or equal to TODAY"
  1. S DIR("B")=$$FMTE^XLFDT(DT)
  1. D ^DIR I $D(DTOUT)!($D(DUOUT)) Q
  1. S GMRCED(5)=Y_U_Y(0)
  1. Q
  1. 6 ;edit ATTN person
  1. N X,Y,DIR
  1. S DIR(0)="PAO^200:EQM",DIR("A")="Select ATTENTION person: "
  1. S DIR("B")=$$GET1^DIQ(200,+$P(^GMR(123,+GMRCO,0),U,11),.01)
  1. S:$D(GMRCED(6)) DIR("B")=$P($G(GMRCED(6)),U,2)
  1. K:'$L(DIR("B")) DIR("B")
  1. D ^DIR I $D(DTOUT)!($D(DUOUT)) Q
  1. I $G(DIR("B"))=$P(Y,U,2) Q
  1. S GMRCED(6)=$S(Y=-1:"",1:Y)
  1. I GMRCED(6)="" W !,?5,"<DELETED>",!
  1. Q
  1. 7 ;edit prov. DX
  1. N X,Y,DIC,DIR,PRMPT
  1. S PRMPT=$$PROVDX^GMRCUTL1(+$P(^GMR(123,+GMRCO,0),U,5))
  1. I $P(PRMPT,U,2)="F" D
  1. . S DIR(0)="FA^2:245",DIR("A")="Provisional Diagnosis: "
  1. . I $P(PRMPT,U)'="R" S $P(DIR(0),U)="FAO"
  1. . S:$D(GMRCED(7)) DIR("B")=$P(GMRCED(7),U)
  1. . I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,+GMRCO,30))
  1. . K:'$L(DIR("B")) DIR("B")
  1. . D ^DIR Q:$D(DTOUT)!($D(DUOUT)) Q:Y=$G(DIR("B"))
  1. . I '$L(Y) W !,?5,"<DELETED>",!
  1. . S GMRCED(7)=Y
  1. I $P(PRMPT,U,2)="L" D
  1. . N DIR,X,Y,DTOUT,DUOUT,VAL
  1. . I $D(GMRCED(7)) D
  1. .. I '$L($P(GMRCED(7),U,2)) S DIR("B")=$P(GMRCED(7),U) Q
  1. .. S DIR("B")=$P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"
  1. . I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,GMRCO,30))
  1. . K:'$L(DIR("B")) DIR("B")
  1. . S DIR("?")="Enter a code or term for the provisional diagnosis."
  1. . S DIR("A")="Provisional Diagnosis: "
  1. . S DIR(0)="FA"_$S($P(PRMPT,U)'="R":"O",1:"")_"^1:245"
  1. . D ^DIR
  1. . I $D(DTOUT)!($D(DUOUT)) Q
  1. . I '$L(Y) W !,?5,"<DELETED>",! S GMRCED(7)="" Q
  1. . I Y=$G(DIR("B")) Q
  1. . I $E(Y,1)=" " W !,"Leading space not allowed, no change." Q
  1. . S VAL=$$LEXLKUP(Y)
  1. . I '$L(VAL),$P(PRMPT,U)="R" W !,"Prov. DX required. No change." Q
  1. . I VAL=$G(^GMR(123,GMRCO,30)) W !,"No change." Q
  1. . I ($P(VAL,U)_" ("_$P(VAL,U,2)_")")=$G(^GMR(123,GMRCO,30)) D Q
  1. .. W !,"No change."
  1. . I '$L(VAL) W !,?5,"<DELETED>",!
  1. . S GMRCED(7)=VAL
  1. Q
  1. ;
  1. LEXLKUP(GMRCX) ; run input through the Lexicon
  1. ;
  1. N DIC,X,Y,DUOUT,DTOUT,GMRCSYS
  1. S GMRCSYS="ICD" I DT>=$$IMPDATE^LEXU("10D") S GMRCSYS="10D"
  1. D CONFIG^LEXSET(GMRCSYS,GMRCSYS,DT)
  1. S DIC="^LEX(757.01,",DIC(0)="EQM",DIC("B")=GMRCX,X=GMRCX
  1. D ^DIC
  1. I $D(DTOUT)!($D(DUOUT))!($G(Y)<1) Q ""
  1. Q $P(Y,U,2)_U_$S(GMRCSYS="ICD":$G(Y(1)),1:$G(Y(30)))
  1. ;
  1. 8 ;edit Reason for Request
  1. N DIC,DIWESUB,DWLW,DWPK
  1. I $D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCEDSV",$J,20)=^TMP("GMRCED",$J,20)
  1. I '$D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCED",$J,20)=^GMR(123,+GMRCO,20)
  1. S DIC="^TMP(""GMRCED"",$J,20,",DIWESUB="Reason for Request"
  1. W !,"Editing Reason for Request:",!
  1. S DWPK=1,DWLW=74 D EN^DIWE
  1. I '$$DIFFRFR($D(^TMP("GMRCEDSV",$J,20))) D Q
  1. . I $D(^TMP("GMRCEDSV",$J,20)) K ^TMP("GMRCEDSV",$J,20) Q
  1. . K ^TMP("GMRCED",$J,20)
  1. K ^TMP("GMRCEDSV",$J,20)
  1. I '$D(^TMP("GMRCED",$J,20))!('$O(^TMP("GMRCED",$J,20,0))) D
  1. . N GMRCMSG
  1. . S GMRCMSG="Unable to delete Reason for Request (REQUIRED)"
  1. . D EXAC^GMRCADC(GMRCMSG)
  1. . K ^TMP("GMRCED",$J,20)
  1. Q
  1. 9 ;add comment
  1. N DIC,DIWEPSE,DIWESUB,DWLW,DWPK
  1. I $D(^TMP("GMRCED",$J,40)) D
  1. . W !,"An unsaved comment exists. You may edit this comment.",!
  1. . S DIWEPSE=1
  1. S DIC="^TMP(""GMRCED"",$J,40,",DIWESUB="New Comment"
  1. W !,"Adding new comment:",!
  1. S DWPK=1,DWLW=74 D EN^DIWE
  1. I '$O(^TMP("GMRCED",$J,40,0)) K ^TMP("GMRCED",$J,40)
  1. Q
  1. DIFFRFR(SAVED) ;edited reason for req same as original?
  1. N I,DIFF
  1. 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
  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
  1. I SAVED S I=0 F S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF)) D
  1. . I ^TMP("GMRCED",$J,20,I,0)=$G(^TMP("GMRCEDSV",$J,20,I,0)) Q
  1. . S DIFF=1
  1. . Q
  1. I 'SAVED S I=0 F S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF)) D
  1. . I ^TMP("GMRCED",$J,20,I,0)'=$G(^GMR(123,+GMRCO,20,I,0)) S DIFF=1
  1. . Q
  1. Q $G(DIFF)
  1. VALIDPL(PL,REND) ; place still valid?
  1. N PLMENU
  1. S PLMENU=$S($P(REND,U)="I":"IN",1:"OUT")
  1. S PLMENU="GMRCPLACEM - "_PLMENU_"PATIENT"
  1. S PLMENU=$$FIND1^DIC(101,,"QX",PLMENU) Q:PLMENU'>1 0
  1. Q $D(^ORD(101,PLMENU,10,"B",+PL))
  1. VALIDUR(URG,REND,PROC) ;urgency still valid?
  1. N URMENU
  1. I $P(REND,U)="I" D
  1. .I 'PROC S URMENU="GMRCURGENCYM CSLT - INPATIENT" Q
  1. .S URMENU="GMRCURGENCYM REQ - INPATIENT" Q
  1. I '$D(URMENU) S URMENU="GMRCURGENCYM - OUTPATIENT"
  1. S URMENU=$$FIND1^DIC(101,,"QX",URMENU) Q:URMENU<0 0
  1. Q $D(^ORD(101,URMENU,10,"B",+URG))
  1. Q
  1. NOCHG() ;no changes made
  1. Q "No Changes made!"
  1. 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.
  1. N MSG,GMRCCPTR,GMRCCSYS,GMRCCODE
  1. I '$L($G(^GMR(123,GMRCDA,30.1))) Q 1
  1. S GMRCCODE=$P($G(^GMR(123,+GMRCO,30.1)),"^",1)
  1. S GMRCCSYS=$P($G(^GMR(123,+GMRCO,30.1)),"^",3)
  1. S GMRCCPTR=$S(GMRCCSYS="ICD":1,1:30)
  1. I +$$STATCHK^ICDEX(GMRCCODE,DT,GMRCCPTR) Q 1 ;code still active
  1. S MSG="The provisional DX code must be edited before this request"
  1. S MSG=MSG_" may be resubmitted."
  1. D EN^DDIOL(MSG,,"!!")
  1. Q 0