ORCDGMRC ;SLC/MKB-Utility functions for GMRC dialogs ; 5/15/13 11:32am
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,26,68,100,181,361**;Dec 17, 1997;Build 39
; External References
; DBIA 10006 Call to ^DIC
; DBIA 10026 Call to ^DIR
; DBIA 2426 Call to SERV1^GMRCASV
; DBIA 3119 Call to GETDEF^GMRCDRFR
; DBIA 2982 Call to GETSVC^GMRCPR0
; DBIA 3121 Call to APIs $$PROVDX and PREREQ in routine ^GMRCUTL1
; DBIA 1609 Call to CONFIG^LEXSET
; DBIA 10104 Call to APIs $$RJ and $$UP in routine ^XLFSTR
; DBIA 10102 Call to DISP^XQORM1
; DBIA 3991 Call to $$STATCHK^ICDAPIU
URGENCY(TYPE) ; -- Returns index of allowable urgencies from file #101.42
N X S X=$S($$VAL^ORCD("CATEGORY")'="I":"O",TYPE="C":"T",1:"R")
S ORDIALOG(PROMPT,"D")="S.GMRC"_X
Q
;
PLACE ; -- Returns list of allowable places of consultation
Q:$D(ORDIALOG(PROMPT,"LIST")) N CHOICES,I,J,INPT,X
S INPT=($$VAL^ORCD("CATEGORY")="I")
I INPT S CHOICES="B^Bedside;C^Consultant's Choice"
I 'INPT S CHOICES="E^Emergency Room;C^Consultant's Choice"
S I=0 F J=1:1:$L(CHOICES,";") S X=$P(CHOICES,";",J) D
. S I=I+1,ORDIALOG(PROMPT,"LIST",I)=X
. S ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR($P(X,U,2)))=$P(X,U)
S ORDIALOG(PROMPT,"LIST")=I_"^1"
Q
;
CHANGED(PRMT) ; -- Kill lists for Request Service or Place of Consultation
N I,P
S I=$S(PRMT="OI":"REQUEST SERVICE",1:"PLACE OF CONSULTATION")
S P=$$PTR^ORCD("OR GTX "_I) Q:'P
K ORDIALOG(P,"LIST"),ORDIALOG(P,1)
Q
;
GETSERV ; -- Get list of orderable services
N GMRCTO,GMRCDG,I,X K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
S (GMRCTO,GMRCDG)=1 D SERV1^GMRCASV ; get list of orderable services
F I=1:1 S X=+$G(^TMP("GMRCSLIST",$J,I)) Q:X'>0 S $P(^TMP("GMRCS",$J,X),U,2)=I
Q
;
LISTSERV(ORI) ; -- List Consult services from ORSERV
N ORSTK,ORCNT,ORX,ORQ
W !,"Choose from:" S:$G(ORI)'>0 ORI=1
S (ORSTK,ORQ)=0,ORCNT=1,ORSTK(0)=$P(^TMP("GMRCSLIST",$J,ORI),U,3)
F S ORX=$G(^TMP("GMRCSLIST",$J,ORI)) Q:ORX="" D Q:ORQ S ORI=ORI+1
. I $P(ORX,U,3)'=+$G(ORSTK(ORSTK)) D POP I ORSTK'>0 S ORQ=1 Q
. S ORCNT=ORCNT+1 I ORCNT>(IOSL-6) S:'$$CONT ORQ=1 Q:$G(ORQ) S ORCNT=1
. W !,?((ORSTK*2)),$P(ORX,U,2)
. W:$P(ORX,U,5) " ("_$S($P(ORX,U,5)=1:"Grouper",1:"Tracking")_" Only)"
. I $P(ORX,U,4)="+" S ORSTK=ORSTK+1,ORSTK(ORSTK)=+ORX
Q
;
POP ; -- pop stack
S ORSTK=ORSTK-1 Q:ORSTK'>0
I ORSTK(ORSTK)'=$P(ORX,U,3) G POP
Q
;
CONT() ; -- continue?
N X,Y,DIR S DIR(0)="E" D ^DIR
Q +Y
;
CKSERV ; -- Ck service usage in Post-Selection Action
N GMRCI,ORI
S GMRCI=+$P(^ORD(101.43,+Y,0),U,2)
S ORI=+$P($G(^TMP("GMRCS",$J,GMRCI)),U,2) S:ORI'>0 ORI=1
I $P($G(^TMP("GMRCSLIST",$J,ORI)),U,5)=1 D LISTSERV^ORCDGMRC(ORI) K DONE
Q
;
PROCSVC ; -- Get list of services for procedure
Q:$D(ORDIALOG(PROMPT,"LIST")) Q:'$L($T(GETSVC^GMRCPR0))
N OI,PROTCL,ORY,ORI,X
S OI=+$$VAL^ORCD("PROCEDURE"),PROTCL=$P($G(^ORD(101.43,OI,0)),U,2) ;ID
D:PROTCL GETSVC^GMRCPR0(.ORY,PROTCL)
I $G(ORY)'>0 W $C(7),!,"There are no services defined for this procedure!" H 1 S ORQUIT=1 Q
M ORDIALOG(PROMPT,"LIST")=ORY S $P(ORDIALOG(PROMPT,"LIST"),U,2)=1
S ORI=0 F S ORI=$O(ORY(ORI)) Q:ORI'>0 S X=$P(ORY(ORI),U,2),ORDIALOG(PROMPT,"LIST","B",X)=+ORY(ORI)
Q
;
CKPROCSV ; -- Make sure procedure has at least one service
N PROT,ORY S PROT=$P($G(^ORD(101.43,+Y,0)),U,2)
D GETSVC^GMRCPR0(.ORY,PROT) I $G(ORY)'>0 W $C(7),!,"There are no services defined for this procedure!",! K DONE
Q
;
NWHELP ; -- help code for NW action
N X
W !!,"Select the type of request you wish to enter, either a consult to a service",!,"or a procedure that may be ordered without a formal consult."
W !!,"Press <return> to continue ..." R X:DTIME
S X="?" D DISP^XQORM1 W !
Q
;
REASON ; -- Get default Reason for Request text for Service
N ORIT,ORSERV,OROOT
S ORIT=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
S ORSERV=$P($G(^ORD(101.43,+ORIT,0)),U,2) Q:'ORSERV!(ORSERV["99PRO")
S OROOT=$NA(^TMP("ORWORD",$J,PROMPT,INST)) D
. N PROMPT,INST,X,Y,DIR,ACTION,REQD,MULT,ITEM,COND ;protect var's
. D GETDEF^GMRCDRFR(OROOT,ORSERV,+$G(ORVP),$S($G(ORVP):1,1:0))
S:$D(^TMP("ORWORD",$J,PROMPT,INST)) Y=OROOT
Q
;
ENPDX ; -- setup Prov Dx field
N CODE
S ORPDX=$$PROVDX^GMRCUTL1($S($D(ORPROC):ORPROC,1:$G(ORSERV)))
S CODE=$$PTR^ORCD("OR GTX CODE")
I $P(ORPDX,U)="S" K ORDIALOG(PROMPT,INST),ORDIALOG(CODE,INST) S COND="I 0" Q
S:$G(ORTYPE)'="Z" REQD=$S($P(ORPDX,U)="R":1,1:0)
K:$P(ORPDX,U,2)'="L" ORDIALOG(CODE,INST)
I $P(ORPDX,U,2)="L" S ORDIALOG(PROMPT,"?")="Select a preliminary diagnosis from the Lexicon, as text or an ICD code." K:'$L($G(ORDIALOG(CODE,INST))) ORDIALOG(PROMPT,INST)
I $L($G(ORDIALOG(CODE,INST))),'$$STATCHK^ICDXCODE("DIAGNOSIS",ORDIALOG(CODE,INST),DT) D ;csv
. D EN^DDIOL("The existing diagnosis is associated with an inactive ICD-9 code.")
. I $G(REQD) D EN^DDIOL("Another code must be selected before proceeding.")
. I '$G(REQD) D EN^DDIOL("If another code is not selected, no code will be saved with the new order.")
. D EN^DDIOL(" ")
. K ORDIALOG(PROMPT,INST),ORDIALOG(CODE,INST)
. S ACTION=$G(ACTION)_"W"
Q
;
LEX ; -- search Lexicon for Prov Dx
I $L($G(ORESET)),ORESET=Y Q ;no change
I Y?1." " K DONE W !!,$C(7),"Use of only spaces not allowed!",! Q
Q:$P(ORPDX,U,2)'="L" ;free text only, no ICD code
N DIC,DUOUT,DTOUT,ORCS
S ORCS="ICD"
I DT>=$$IMPDATE^LEXU("10D") S ORCS="10D"
D CONFIG^LEXSET(ORCS,ORCS,DT)
S DIC="^LEX(757.01,",DIC(0)="EQM",DIC("A")="Provisional Diagnosis: "
S:$L($G(ORESET)) DIC("B")=ORESET
D ^DIC I Y'>0 D Q
. I $L($G(ORESET)) S ORDIALOG(PROMPT,ORI)=ORESET
. E K ORDIALOG(PROMPT,ORI)
. I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q
. I REQD,'$D(ORDIALOG(PROMPT,ORI)) K DONE W !!,$C(7),$$REQUIRED^ORCDLG1,!
S ORDIALOG(PROMPT,ORI)=$P(Y,U,2)
I ORCS="ICD" S ORDIALOG($$PTR^ORCD("OR GTX CODE"),ORI)=$G(Y(1)) K Y(1)
I ORCS="10D" S ORDIALOG($$PTR^ORCD("OR GTX CODE"),ORI)=$G(Y(30)) K Y(30)
Q
;
SERVMSG ; -- Get, display text message for service ORSERV
Q:'$G(ORSERV)&('$G(ORPROC)) Q:'FIRST ;show first time only
N ORTXT,I,CNT,HDR S HDR=$S($G(ORMENU):5,1:7)
D PREREQ^GMRCUTL1("ORTXT",$S($D(ORPROC):ORPROC,1:ORSERV),+ORVP)
Q:'$D(ORTXT)
I $D(ORPROC) W !!,$$RJ^XLFSTR("** Procedure Pre-requisite **",57)
E W !!,$$RJ^XLFSTR("** Consult Service Pre-requisite **",57)
S (I,CNT)=0 F S I=$O(ORTXT(I)) Q:I'>0 D Q:$G(ORQUIT)
. S CNT=CNT+1 I CNT>(IOSL-HDR) S CNT=0 I '$$CONT S ORQUIT=1 Q
. W !,ORTXT(I,0)
Q:$G(ORQUIT) S:'$$CONT ORQUIT=1 W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDGMRC 6573 printed Apr 09, 2024@21:25:30 Page 2
ORCDGMRC ;SLC/MKB-Utility functions for GMRC dialogs ; 5/15/13 11:32am
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,26,68,100,181,361**;Dec 17, 1997;Build 39
+2 ; External References
+3 ; DBIA 10006 Call to ^DIC
+4 ; DBIA 10026 Call to ^DIR
+5 ; DBIA 2426 Call to SERV1^GMRCASV
+6 ; DBIA 3119 Call to GETDEF^GMRCDRFR
+7 ; DBIA 2982 Call to GETSVC^GMRCPR0
+8 ; DBIA 3121 Call to APIs $$PROVDX and PREREQ in routine ^GMRCUTL1
+9 ; DBIA 1609 Call to CONFIG^LEXSET
+10 ; DBIA 10104 Call to APIs $$RJ and $$UP in routine ^XLFSTR
+11 ; DBIA 10102 Call to DISP^XQORM1
+12 ; DBIA 3991 Call to $$STATCHK^ICDAPIU
URGENCY(TYPE) ; -- Returns index of allowable urgencies from file #101.42
+1 NEW X
SET X=$SELECT($$VAL^ORCD("CATEGORY")'="I":"O",TYPE="C":"T",1:"R")
+2 SET ORDIALOG(PROMPT,"D")="S.GMRC"_X
+3 QUIT
+4 ;
PLACE ; -- Returns list of allowable places of consultation
+1 if $DATA(ORDIALOG(PROMPT,"LIST"))
QUIT
NEW CHOICES,I,J,INPT,X
+2 SET INPT=($$VAL^ORCD("CATEGORY")="I")
+3 IF INPT
SET CHOICES="B^Bedside;C^Consultant's Choice"
+4 IF 'INPT
SET CHOICES="E^Emergency Room;C^Consultant's Choice"
+5 SET I=0
FOR J=1:1:$LENGTH(CHOICES,";")
SET X=$PIECE(CHOICES,";",J)
Begin DoDot:1
+6 SET I=I+1
SET ORDIALOG(PROMPT,"LIST",I)=X
+7 SET ORDIALOG(PROMPT,"LIST","B",$$UP^XLFSTR($PIECE(X,U,2)))=$PIECE(X,U)
End DoDot:1
+8 SET ORDIALOG(PROMPT,"LIST")=I_"^1"
+9 QUIT
+10 ;
CHANGED(PRMT) ; -- Kill lists for Request Service or Place of Consultation
+1 NEW I,P
+2 SET I=$SELECT(PRMT="OI":"REQUEST SERVICE",1:"PLACE OF CONSULTATION")
+3 SET P=$$PTR^ORCD("OR GTX "_I)
if 'P
QUIT
+4 KILL ORDIALOG(P,"LIST"),ORDIALOG(P,1)
+5 QUIT
+6 ;
GETSERV ; -- Get list of orderable services
+1 NEW GMRCTO,GMRCDG,I,X
KILL ^TMP("GMRCS",$JOB),^TMP("GMRCSLIST",$JOB)
+2 ; get list of orderable services
SET (GMRCTO,GMRCDG)=1
DO SERV1^GMRCASV
+3 FOR I=1:1
SET X=+$GET(^TMP("GMRCSLIST",$JOB,I))
if X'>0
QUIT
SET $PIECE(^TMP("GMRCS",$JOB,X),U,2)=I
+4 QUIT
+5 ;
LISTSERV(ORI) ; -- List Consult services from ORSERV
+1 NEW ORSTK,ORCNT,ORX,ORQ
+2 WRITE !,"Choose from:"
if $GET(ORI)'>0
SET ORI=1
+3 SET (ORSTK,ORQ)=0
SET ORCNT=1
SET ORSTK(0)=$PIECE(^TMP("GMRCSLIST",$JOB,ORI),U,3)
+4 FOR
SET ORX=$GET(^TMP("GMRCSLIST",$JOB,ORI))
if ORX=""
QUIT
Begin DoDot:1
+5 IF $PIECE(ORX,U,3)'=+$GET(ORSTK(ORSTK))
DO POP
IF ORSTK'>0
SET ORQ=1
QUIT
+6 SET ORCNT=ORCNT+1
IF ORCNT>(IOSL-6)
if '$$CONT
SET ORQ=1
if $GET(ORQ)
QUIT
SET ORCNT=1
+7 WRITE !,?((ORSTK*2)),$PIECE(ORX,U,2)
+8 if $PIECE(ORX,U,5)
WRITE " ("_$SELECT($PIECE(ORX,U,5)=1:"Grouper",1:"Tracking")_" Only)"
+9 IF $PIECE(ORX,U,4)="+"
SET ORSTK=ORSTK+1
SET ORSTK(ORSTK)=+ORX
End DoDot:1
if ORQ
QUIT
SET ORI=ORI+1
+10 QUIT
+11 ;
POP ; -- pop stack
+1 SET ORSTK=ORSTK-1
if ORSTK'>0
QUIT
+2 IF ORSTK(ORSTK)'=$PIECE(ORX,U,3)
GOTO POP
+3 QUIT
+4 ;
CONT() ; -- continue?
+1 NEW X,Y,DIR
SET DIR(0)="E"
DO ^DIR
+2 QUIT +Y
+3 ;
CKSERV ; -- Ck service usage in Post-Selection Action
+1 NEW GMRCI,ORI
+2 SET GMRCI=+$PIECE(^ORD(101.43,+Y,0),U,2)
+3 SET ORI=+$PIECE($GET(^TMP("GMRCS",$JOB,GMRCI)),U,2)
if ORI'>0
SET ORI=1
+4 IF $PIECE($GET(^TMP("GMRCSLIST",$JOB,ORI)),U,5)=1
DO LISTSERV^ORCDGMRC(ORI)
KILL DONE
+5 QUIT
+6 ;
PROCSVC ; -- Get list of services for procedure
+1 if $DATA(ORDIALOG(PROMPT,"LIST"))
QUIT
if '$LENGTH($TEXT(GETSVC^GMRCPR0))
QUIT
+2 NEW OI,PROTCL,ORY,ORI,X
+3 ;ID
SET OI=+$$VAL^ORCD("PROCEDURE")
SET PROTCL=$PIECE($GET(^ORD(101.43,OI,0)),U,2)
+4 if PROTCL
DO GETSVC^GMRCPR0(.ORY,PROTCL)
+5 IF $GET(ORY)'>0
WRITE $CHAR(7),!,"There are no services defined for this procedure!"
HANG 1
SET ORQUIT=1
QUIT
+6 MERGE ORDIALOG(PROMPT,"LIST")=ORY
SET $PIECE(ORDIALOG(PROMPT,"LIST"),U,2)=1
+7 SET ORI=0
FOR
SET ORI=$ORDER(ORY(ORI))
if ORI'>0
QUIT
SET X=$PIECE(ORY(ORI),U,2)
SET ORDIALOG(PROMPT,"LIST","B",X)=+ORY(ORI)
+8 QUIT
+9 ;
CKPROCSV ; -- Make sure procedure has at least one service
+1 NEW PROT,ORY
SET PROT=$PIECE($GET(^ORD(101.43,+Y,0)),U,2)
+2 DO GETSVC^GMRCPR0(.ORY,PROT)
IF $GET(ORY)'>0
WRITE $CHAR(7),!,"There are no services defined for this procedure!",!
KILL DONE
+3 QUIT
+4 ;
NWHELP ; -- help code for NW action
+1 NEW X
+2 WRITE !!,"Select the type of request you wish to enter, either a consult to a service",!,"or a procedure that may be ordered without a formal consult."
+3 WRITE !!,"Press <return> to continue ..."
READ X:DTIME
+4 SET X="?"
DO DISP^XQORM1
WRITE !
+5 QUIT
+6 ;
REASON ; -- Get default Reason for Request text for Service
+1 NEW ORIT,ORSERV,OROOT
+2 SET ORIT=$GET(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
+3 SET ORSERV=$PIECE($GET(^ORD(101.43,+ORIT,0)),U,2)
if 'ORSERV!(ORSERV["99PRO")
QUIT
+4 SET OROOT=$NAME(^TMP("ORWORD",$JOB,PROMPT,INST))
Begin DoDot:1
+5 ;protect var's
NEW PROMPT,INST,X,Y,DIR,ACTION,REQD,MULT,ITEM,COND
+6 DO GETDEF^GMRCDRFR(OROOT,ORSERV,+$GET(ORVP),$SELECT($GET(ORVP):1,1:0))
End DoDot:1
+7 if $DATA(^TMP("ORWORD",$JOB,PROMPT,INST))
SET Y=OROOT
+8 QUIT
+9 ;
ENPDX ; -- setup Prov Dx field
+1 NEW CODE
+2 SET ORPDX=$$PROVDX^GMRCUTL1($SELECT($DATA(ORPROC):ORPROC,1:$GET(ORSERV)))
+3 SET CODE=$$PTR^ORCD("OR GTX CODE")
+4 IF $PIECE(ORPDX,U)="S"
KILL ORDIALOG(PROMPT,INST),ORDIALOG(CODE,INST)
SET COND="I 0"
QUIT
+5 if $GET(ORTYPE)'="Z"
SET REQD=$SELECT($PIECE(ORPDX,U)="R":1,1:0)
+6 if $PIECE(ORPDX,U,2)'="L"
KILL ORDIALOG(CODE,INST)
+7 IF $PIECE(ORPDX,U,2)="L"
SET ORDIALOG(PROMPT,"?")="Select a preliminary diagnosis from the Lexicon, as text or an ICD code."
if '$LENGTH($GET(ORDIALOG(CODE,INST)))
KILL ORDIALOG(PROMPT,INST)
+8 ;csv
IF $LENGTH($GET(ORDIALOG(CODE,INST)))
IF '$$STATCHK^ICDXCODE("DIAGNOSIS",ORDIALOG(CODE,INST),DT)
Begin DoDot:1
+9 DO EN^DDIOL("The existing diagnosis is associated with an inactive ICD-9 code.")
+10 IF $GET(REQD)
DO EN^DDIOL("Another code must be selected before proceeding.")
+11 IF '$GET(REQD)
DO EN^DDIOL("If another code is not selected, no code will be saved with the new order.")
+12 DO EN^DDIOL(" ")
+13 KILL ORDIALOG(PROMPT,INST),ORDIALOG(CODE,INST)
+14 SET ACTION=$GET(ACTION)_"W"
End DoDot:1
+15 QUIT
+16 ;
LEX ; -- search Lexicon for Prov Dx
+1 ;no change
IF $LENGTH($GET(ORESET))
IF ORESET=Y
QUIT
+2 IF Y?1." "
KILL DONE
WRITE !!,$CHAR(7),"Use of only spaces not allowed!",!
QUIT
+3 ;free text only, no ICD code
if $PIECE(ORPDX,U,2)'="L"
QUIT
+4 NEW DIC,DUOUT,DTOUT,ORCS
+5 SET ORCS="ICD"
+6 IF DT>=$$IMPDATE^LEXU("10D")
SET ORCS="10D"
+7 DO CONFIG^LEXSET(ORCS,ORCS,DT)
+8 SET DIC="^LEX(757.01,"
SET DIC(0)="EQM"
SET DIC("A")="Provisional Diagnosis: "
+9 if $LENGTH($GET(ORESET))
SET DIC("B")=ORESET
+10 DO ^DIC
IF Y'>0
Begin DoDot:1
+11 IF $LENGTH($GET(ORESET))
SET ORDIALOG(PROMPT,ORI)=ORESET
+12 IF '$TEST
KILL ORDIALOG(PROMPT,ORI)
+13 IF $DATA(DTOUT)!$DATA(DUOUT)
SET ORQUIT=1
QUIT
+14 IF REQD
IF '$DATA(ORDIALOG(PROMPT,ORI))
KILL DONE
WRITE !!,$CHAR(7),$$REQUIRED^ORCDLG1,!
End DoDot:1
QUIT
+15 SET ORDIALOG(PROMPT,ORI)=$PIECE(Y,U,2)
+16 IF ORCS="ICD"
SET ORDIALOG($$PTR^ORCD("OR GTX CODE"),ORI)=$GET(Y(1))
KILL Y(1)
+17 IF ORCS="10D"
SET ORDIALOG($$PTR^ORCD("OR GTX CODE"),ORI)=$GET(Y(30))
KILL Y(30)
+18 QUIT
+19 ;
SERVMSG ; -- Get, display text message for service ORSERV
+1 ;show first time only
if '$GET(ORSERV)&('$GET(ORPROC))
QUIT
if 'FIRST
QUIT
+2 NEW ORTXT,I,CNT,HDR
SET HDR=$SELECT($GET(ORMENU):5,1:7)
+3 DO PREREQ^GMRCUTL1("ORTXT",$SELECT($DATA(ORPROC):ORPROC,1:ORSERV),+ORVP)
+4 if '$DATA(ORTXT)
QUIT
+5 IF $DATA(ORPROC)
WRITE !!,$$RJ^XLFSTR("** Procedure Pre-requisite **",57)
+6 IF '$TEST
WRITE !!,$$RJ^XLFSTR("** Consult Service Pre-requisite **",57)
+7 SET (I,CNT)=0
FOR
SET I=$ORDER(ORTXT(I))
if I'>0
QUIT
Begin DoDot:1
+8 SET CNT=CNT+1
IF CNT>(IOSL-HDR)
SET CNT=0
IF '$$CONT
SET ORQUIT=1
QUIT
+9 WRITE !,ORTXT(I,0)
End DoDot:1
if $GET(ORQUIT)
QUIT
+10 if $GET(ORQUIT)
QUIT
if '$$CONT
SET ORQUIT=1
WRITE !
+11 QUIT
