GMRCSRVS ;SLC/DCM,JFR - Add/Edit services in File 123.5. ;30-Jul-2013 17:56;DU
;;3.0;CONSULT/REQUEST TRACKING;**1,16,40,53,63,1004**;DEC 27, 1997;Build 12
;
EN ;set up services entry point
;GMRCOLDU=Service Usage field. If changed, GMRCOLDU shows the change (See ^DD(123.5,2,0) for field description).
N GMRCSAFE,GMRCOLDU,GMRCOLDS,GMRCOSNM,GMRCSRVC,GMRCACT,GMRCSSNM
N DIC,DLAYGO,DUOUT,DTOUT
S DIC="^GMR(123.5,",DLAYGO=123.5,DIC(0)="AELMQZ",DIC("A")="Select Service/Specialty:"
D ^DIC I $S(Y<0:1,$D(DTOUT):1,$D(DUOUT):1,1:0) D END K GMRCMSG,DTOUT,DUOUT Q
D
.S GMRCSAFE=+$G(^GMR(123.5,+Y,"INT"))
.S (DA,GMRCSRVC)=+Y,GMRCOSNM=$P(Y,"^",2),(GMRCOLDU,GMRCOLDS)=""
.S GMRCACT=$S('$O(^GMR(123.5,+Y,0)):"MAD",1:"MUP"),GMRCOLDU=$P(^(0),"^",2),GMRCOLDN=$P(^(0),"^",1) S ND=0,GMRCOLDS="" F S ND=$O(^GMR(123.5,+Y,2,ND)) Q:ND?1A.E!(ND="") S GMRCOLDS=GMRCOLDS_^GMR(123.5,+Y,2,ND,0)_"^"
.S DIE=DIC,DR="[GMRC SETUP REQUEST MU]",DIE("NO^")="OUTOK"
.D ^DIE
.Q
I $D(DA) S GMRCACT=$S($P(^GMR(123.5,GMRCSRVC,0),"^",2)=9:"MDC",$P(^(0),"^",2)=1:"MDC",1:GMRCACT) D
.S GMRCSSNM=$P(^GMR(123.5,GMRCSRVC,0),"^",1)
.I GMRCACT'="MAD",GMRCSSNM'=GMRCOSNM S GMRCACT="MUP"
.I $S(GMRCACT'="MAD":1,GMRCACT'="MUP":1,1:0),$L(GMRCOLDU),GMRCOLDU=$P(^GMR(123.5,GMRCSRVC,0),"^",2) S GMRCACT="NOACT"
.I $S(GMRCACT="MUP":1,GMRCACT="NOACT":1,1:0),GMRCOLDN'=$P(^GMR(123.5,GMRCSRVC,0),"^",1) S GMRCACT="MUP"
.S ND=0 F S ND=$O(^GMR(123.5,GMRCSRVC,2,ND)) Q:ND?1A.E!(ND="") I GMRCOLDS'=""&(^GMR(123.5,GMRCSRVC,2,ND,0)'=""),GMRCOLDS'[^GMR(123.5,GMRCSRVC,2,ND,0) S GMRCACT="MUP" Q
.I $S(GMRCACT="MAD":1,GMRCACT="MUP":1,GMRCACT="MDC":1,1:0) D SVC^GMRC101H(GMRCSRVC,GMRCSSNM,GMRCACT),MSG^XQOR("GMRC ORDERABLE ITEM UPDATE",.GMRCMSG)
.D PTRCLN^GMRCU
.Q
;IHS/MSC/MGH Patch 1004 for Meaningful Use
;Find and/or add the SNOMED CONCEPT CT for this referral
K ^TMP("GMRCSNO",$J),^TMP($J)
N IN,OUT,DIC,X,CNT,CT,CCT,SNOMED,DIC,DIE,SCODE,VAR,DESC
S CT=0,DESC=""
S CCT=$$GET1^DIQ(123.5,GMRCSRVC,9999999.01)
S IN=CCT_"^30^^1"
S OUT="VAR"
S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
I X>0 D
.S DESC=$G(VAR(1,"PRE","TRM"))
.I DESC="" S DESC=CCT
W !!,"SNOMED Consult Type"
W !,"Current value is: "_DESC,!
S DIR(0)="Y",DIR("A")="Would you like to edit"
S DIR("?")="Enter 'Yes' or 'No'" D ^DIR K DIR
Q:$D(DTOUT)
I X="Y" D
.S IN="EHR REFERRAL TYPE^30^1"
.S OUT="^TMP(""GMRCSNO"",$J)"
.S X=$$SUBLST^BSTSAPI(.OUT,.IN)
.S CNT="" F S CNT=$O(@OUT@(CNT)) Q:CNT="" D
..S ^TMP($J,CNT,0)=$P(@OUT@(CNT),U,3)
..S ^TMP($J,"B",$P(@OUT@(CNT),U,3))=CNT
..S CT=CT+1
.S ^TMP($J,0)=U_U_CT_U_CT
.W !!,"Enter ? to see the list of SNOMED Consult Types"
.W !,"Enter ^ to quit the selection",!
.S DIC="^TMP($J," S DIC(0)="AEQ",DIC("A")="Select SNOMED TYPE: "
.S DIC("B")=DESC
.D ^DIC
.S SNOMED=Y
.I SNOMED'=-1 D
..K Y,DIE,DA,DR
..S SCODE=$P(^TMP("GMRCSNO",$J,$P(SNOMED,U,1)),U,1)
..S DIE="^GMR(123.5,",DA=GMRCSRVC,DR="9999999.01///"_SCODE
..D ^DIE
;end IHS MOD
K GMRCMSG,GMRCSSNM,GMRCSRVS,GMRCOLDN,GMRCOLDS,GMRCOLDU,ND
;Ask to continue...
;
N GMRC0,GMRCA,GMRCB,GMRCH,GMRCL
S GMRC0="YA",GMRCA="Add/Edit Another Service? ",GMRCB="NO"
S GMRCH="Enter 'YES' to add/edit another service, or 'NO' to exit."
S GMRCL=2
I '+$$READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL) D END Q
G EN
;
END K DIC,DIE,DTOUT,DUOUT,DA,DR,FL,GMRCACT,GMRCANS,GMRCMSG,GMRCREA,GMRCSRVC,GMRCSSNM,REVCODE,RLEVCODE,Y
Q
;
READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL,GMRCS) ;
;
; GMRC0 -> DIR(0) --- Type of read
; GMRCA -> DIR("A") - Prompt
; GMRCB -> DIR("B") - Default Answer
; GMRCH -> DIR("?") - Help text or ^Execute code
; GMRCS -> DIR("S") - Screen
; GMRCL -> Number of blank lines to put before Prompt
;
; Returns "^" or answer
;
N GMRCLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
Q:'$L($G(GMRC0)) U
S DIR(0)=GMRC0
S:$L($G(GMRCA)) DIR("A")=GMRCA
I $D(GMRCA("A")) M DIR("A")=GMRCA("A")
S:$L($G(GMRCB)) DIR("B")=GMRCB
I $D(GMRCH("?")) M DIR("?")=GMRCH("?")
S:$L($G(GMRCH)) DIR("?")=GMRCH
S:$L($G(GMRCS)) DIR("S")=GMRCS
F GMRCLINE=1:1:($G(GMRCL)-1) W !
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
Q Y
;
NOED(SERV) ;
I '$D(^GMR(123.5,+SERV,0)) Q 0
N NAME
S NAME=$P(^GMR(123.5,+SERV,0),U)
I NAME="PROSTHETICS REQUEST" Q 1
I NAME="EYEGLASS REQUEST" Q 1
I NAME="CONTACT LENS REQUEST" Q 1
I NAME="HOME OXYGEN REQUEST" Q 1
Q 0
;
CLONPSAS ; clone a PROSTHETICS service
; choose service and text to append
N GMRCSIEN,GMRCROOT,GMRCNWNM
N GMRCCPY,GMRCNEW,FDA,GMRCERR,GMRC
S GMRC(0)="PAO^GMR(123.5,:AEMQ"
S GMRC("A")="Select the Prosthetics Service to clone: "
S GMRC("S")="I $$NOED^GMRCSRVS(+Y)"
S GMRCCPY=+$$READ(GMRC(0),GMRC("A"),,,2,GMRC("S"))
I 'GMRCCPY Q
K GMRC
S GMRCNWNM=$$GETAPP(GMRCCPY)
I '$L(GMRCNWNM) Q
S FDA(1,123.5,"+1,",.01)=GMRCNWNM
S FDA(1,123.5,"+1,",2)="DISABLED"
S FDA(1,123.5,"+1,",1.01)="REQUIRE"
S FDA(1,123.5,"+1,",1.02)="LEXICON"
S FDA(1,123.5,"+1,",123.01)="CONSULTS"
S FDA(1,123.5,"+1,",123.03)="GMRCACTM SERVICE ACTION MENU"
S FDA(1,123.5,"+1,",131)="YES"
D UPDATE^DIE("E","FDA(1)","GMRCNEW","GMRCERR")
I '$D(GMRCNEW) W !,"Failed to create new entry. Please try again" Q
W !!,GMRCNWNM," created",!
S GMRCSIEN=GMRCNEW(1)_","
S GMRCROOT="^GMR(123.5,"_GMRCCPY_",124)"
D WP^DIE(123.5,GMRCSIEN,124,,GMRCROOT,"GMRCERR")
W !!,"The new Service is currently DISABLED. To activate this service for use in"
W !,"the Prosthetics interface, you MUST use the Setup Consult Services option"
W !,"and delete the DISABLED flag from the SERVICE USAGE field.",!
Q
GETAPP(GMRIEN) ;get text to append
N GMRCNWNM,QTFLG,I,GMRC,GMRCHL,OK
S GMRCNWNM=""
F I=0:0 D Q:$G(QTFLG)
. W !!
. S GMRC(0)="FA^3:40"
. S GMRC("A")="Enter text to append to national service name: "
. S GMRCHL("?",1)="The text entered will be appended to the name of the exported service"
. S GMRCHL("?")="(e.g. If HINES was entered it may appear as PROSTHETICS REQUEST - HINES"
. S GMRCNWNM=$$READ(GMRC(0),GMRC("A"),,.GMRCHL,2)
. I '$L(GMRCNWNM)!(GMRCNWNM["^") S GMRCNWNM="",QTFLG=1 Q
. K GMRC,GMRCHL
. S GMRCNWNM=$P(^GMR(123.5,GMRIEN,0),U)_" - "_GMRCNWNM
. I $$FIND1^DIC(123.5,,"X",GMRCNWNM) D Q
.. W !!,$C(7),"This service already exists, you'll have to try again!",!
.. S GMRCNWNM=""
. W !,"The new service name will be:"
. W !,?5,GMRCNWNM,!
. S OK=+$$READ("Y","Is this OK",,,1)
. I OK=U S QTFLG=1 Q
. I 'OK S GMRCNWNM="" Q
. S QTFLG=1
Q GMRCNWNM
INPUT(X,GMRCDA) ; INPUT TRANSFORM FOR THE SUB-SERVICE/SPECIALTY (#.01) FIELD
; OF THE SUB-SERVICE (#123.51) FILE WHICH IS A SUB-FILE OF THE
; SUB-SERVICE (#10) FIELD OF THE REQUEST SERVICES (#123.5) FILE.
;
; X = INTERNAL VALUE OF USER SELECTED SUB-SERVICE (IEN OF SERVICE
; IN FILE 123.5)
; GMRCDA = IEN OF INITIAL PARENT SERVICE IN FILE 123.5
;
I +$G(X)=0 K X Q
I GMRCDA<1 D Q:'$D(X)
. S GMRCDA=+$G(D0)
. I GMRCDA<1 K X
N GMRPARNT,GMRCHILD,GMRQ,GMRCNT
K ^TMP("GMRC INPUT",$J) ;MAKE SURE INPUT PARENT LOG GLOBAL IS BLANK
I X=GMRCDA S GMRQ=1 G INPUTQ ;NOT ALLOW SERVICE AS A SUB-SERVICE TO ITSELF
S ^TMP("GMRC INPUT",$J,"B",GMRCDA)="" ;USED TO PREVENT DUPLICATE CHECKING OF PARENTS
S ^TMP("GMRC INPUT",$J,0)=1 ;USED TO FIND NEXT NUMBER FOR TMP GLOBAL ENTRY
S ^TMP("GMRC INPUT",$J,1)=GMRCDA ;PARENT IEN STORED TO BE USED AS CHILD
S (GMRCNT,GMRQ)=0
F S GMRCNT=$O(^TMP("GMRC INPUT",$J,GMRCNT)) Q:'GMRCNT D Q:GMRQ=1
. S GMRCHILD=$G(^TMP("GMRC INPUT",$J,GMRCNT))
. S GMRPARNT=0
. F S GMRPARNT=$O(^GMR(123.5,"APC",GMRCHILD,GMRPARNT)) Q:GMRPARNT="" D Q:GMRQ=1
.. I GMRPARNT=X S GMRQ=1 Q ;NOT ALLOW SERVICE AS A SUB-SERVICE WITHIN IT'S SUB-SERVICE HIERARCHY
.. I '$D(^TMP("GMRC INPUT",$J,"B",GMRPARNT)) D ;IF NOT IN LIST ADD
... S ^TMP("GMRC INPUT",$J,"B",GMRPARNT)="" ;ADD TO "B" CROSS-REFERENCE
... S ^TMP("GMRC INPUT",$J,0)=$G(^TMP("GMRC INPUT",$J,0))+1 ;INCREASE LAST NUMBER BY 1
... S ^TMP("GMRC INPUT",$J,$G(^TMP("GMRC INPUT",$J,0)))=GMRPARNT ;ADD NEW PARENT SERVICE TO GLOBAL SO IT CAN BE CHECKED AS A CHILD ENTRY TO FIND IT'S PARENTS
K ^TMP("GMRC INPUT",$J)
INPUTQ I GMRQ=1 D EN^DDIOL("A SERVICE CAN NOT BE A SUB-SERVICE OF ITSELF","","!!?12") K X Q
;
DUPCHK ;CHECK FOR CONSULT SERVICES APPEARING AS PART OF THE CONSULT SERVICE
;HIERARCHY IN MORE THAN ONE PLACE
N ARRAY,COUNT,GMRCON,PARENT
S PARENT=0
;Check if they are a sub-service to more than one service.
F COUNT=0:1 S PARENT=$O(^GMR(123.5,"APC",X,PARENT)) Q:'+PARENT
;Print message about which services this service is a sub-service of.
I COUNT'>0 Q
S COUNT=1
S ARRAY(COUNT)=" ",COUNT=COUNT+1
S ARRAY(COUNT)=" ",COUNT=COUNT+1
S ARRAY="Service "_$P(^GMR(123.5,X,0),"^",1)_" is already a sub-service of:"
D PARSE(.ARRAY)
S PARENT=0
F S PARENT=$O(^GMR(123.5,"APC",X,PARENT)) Q:'+PARENT S ARRAY=" "_$P(^GMR(123.5,PARENT,0),"^",1) D PARSE(.ARRAY)
S ARRAY(COUNT)=" ",COUNT=COUNT+1
S ARRAY(COUNT)="A consult service appearing as part of the Consult service",COUNT=COUNT+1
S ARRAY(COUNT)="hierarchy in more than one place (i.e. a sub-service of more",COUNT=COUNT+1
S ARRAY(COUNT)="than one parent) has the potential to skew the results of the",COUNT=COUNT+1
S ARRAY(COUNT)="Consult Performance Monitor Report [GMRC RPT PERF MONITOR].",COUNT=COUNT+1
S ARRAY(COUNT)=" ",COUNT=COUNT+1
D EN^DDIOL(.ARRAY)
I '$G(DIQUIET) D
. S GMRCON=0
. D YESNO(X,Y)
. I 'GMRCON K X
. D EN^DDIOL(" ")
Q
PARSE(ARRAY) ;TAKE ARRAY VALUE AND PARSE INTO PIECES SHORTER THAN 70 CHARACTERS
N ARRAYSP,GMRCNT
PARSE1 I $L(ARRAY)'>70 S ARRAY(COUNT)=ARRAY,COUNT=COUNT+1 Q
F GMRCNT=70:-1 S ARRAYSP=$E(ARRAY,GMRCNT) I ARRAYSP=" " Q
S ARRAY(COUNT)=$E(ARRAY,1,GMRCNT-1),COUNT=COUNT+1
S ARRAY=$E(ARRAY,GMRCNT+1,9999)
G:ARRAY'="" PARSE1
Q
YESNO(X,Y) ;YES/NO QUESTION/RESPONSE
N DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA"
S DIR("A")="Do you wish to continue adding "_$P(^GMR(123.5,X,0),"^",1)_" as a new sub-service? "
S DIR("B")="NO"
S DIR("T")=300
S DIR("?",1)="Enter ""YES"" to add service as a sub-service."
S DIR("?")="Enter ""NO"" to NOT add the service as a sub-service."
D ^DIR Q:($G(DTOUT))!($G(DUOUT))!($G(DIROUT))
I Y=1 S GMRCON=1
Q
;IHS/MSC/MGH Patch 1004 See if the alert has a note
CONFIN(RET,XQAID) ;EP
N TYPE,AIEN,FDA,IEN,ERR,ORY
S RET="",ORY=""
;D GETDATA^ORWORB(.ORY,XQAID)
S ORY=$P(XQAID,"|",1)
I $D(^GMR(123,+ORY,50))>1 D
.;See if the viewer is the ordering provider
.I DUZ=$$GET1^DIQ(123,+ORY,10,"I") D
..;DO LOOKUP INTO NEW FILE HERE
..F TYPE=371530004,371531000 D
...S AIEN="+1,"_+ORY_","
...S FDA(123.999999911,AIEN,.01)=TYPE
...S FDA(123.999999911,AIEN,2)=$$NOW^XLFDT
...S FDA(123.999999911,AIEN,1)=DUZ
...D UPDATE^DIE(,"FDA","IEN","ERR")
...I $D(ERR) S RET="-1^Error on storing SNOMED terms"
...E S RET=0
...K FDA,IEN,ERR
Q
IND() ;Change choices on clin indication
N DIR,Y,DEF
S DIR(0)="SO^O:Optional"
S DIR("A")="CLINICAL INDICATION"
S DIR("B")=$S($P($G(^GMR(123.5,DA,1)),"^",1)="O":"O",1:"")
S DIR("?")="Enter O if clinical indication is optional, otherwise required."
D ^DIR
I Y="" S Y="@"
Q Y
GMRCSRVS ;SLC/DCM,JFR - Add/Edit services in File 123.5. ;30-Jul-2013 17:56;DU
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,16,40,53,63,1004**;DEC 27, 1997;Build 12
+2 ;
EN ;set up services entry point
+1 ;GMRCOLDU=Service Usage field. If changed, GMRCOLDU shows the change (See ^DD(123.5,2,0) for field description).
+2 NEW GMRCSAFE,GMRCOLDU,GMRCOLDS,GMRCOSNM,GMRCSRVC,GMRCACT,GMRCSSNM
+3 NEW DIC,DLAYGO,DUOUT,DTOUT
+4 SET DIC="^GMR(123.5,"
SET DLAYGO=123.5
SET DIC(0)="AELMQZ"
SET DIC("A")="Select Service/Specialty:"
+5 DO ^DIC
IF $SELECT(Y<0:1,$DATA(DTOUT):1,$DATA(DUOUT):1,1:0)
DO END
KILL GMRCMSG,DTOUT,DUOUT
QUIT
+6 Begin DoDot:1
+7 SET GMRCSAFE=+$GET(^GMR(123.5,+Y,"INT"))
+8 SET (DA,GMRCSRVC)=+Y
SET GMRCOSNM=$PIECE(Y,"^",2)
SET (GMRCOLDU,GMRCOLDS)=""
+9 SET GMRCACT=$SELECT('$ORDER(^GMR(123.5,+Y,0)):"MAD",1:"MUP")
SET GMRCOLDU=$PIECE(^(0),"^",2)
SET GMRCOLDN=$PIECE(^(0),"^",1)
SET ND=0
SET GMRCOLDS=""
FOR
SET ND=$ORDER(^GMR(123.5,+Y,2,ND))
IF ND?1A.E!(ND="")
QUIT
SET GMRCOLDS=GMRCOLDS_^GMR(123.5,+Y,2,ND,0)_"^"
+10 SET DIE=DIC
SET DR="[GMRC SETUP REQUEST MU]"
SET DIE("NO^")="OUTOK"
+11 DO ^DIE
+12 QUIT
End DoDot:1
+13 IF $DATA(DA)
SET GMRCACT=$SELECT($PIECE(^GMR(123.5,GMRCSRVC,0),"^",2)=9:"MDC",$PIECE(^(0),"^",2)=1:"MDC",1:GMRCACT)
Begin DoDot:1
+14 SET GMRCSSNM=$PIECE(^GMR(123.5,GMRCSRVC,0),"^",1)
+15 IF GMRCACT'="MAD"
IF GMRCSSNM'=GMRCOSNM
SET GMRCACT="MUP"
+16 IF $SELECT(GMRCACT'="MAD":1,GMRCACT'="MUP":1,1:0)
IF $LENGTH(GMRCOLDU)
IF GMRCOLDU=$PIECE(^GMR(123.5,GMRCSRVC,0),"^",2)
SET GMRCACT="NOACT"
+17 IF $SELECT(GMRCACT="MUP":1,GMRCACT="NOACT":1,1:0)
IF GMRCOLDN'=$PIECE(^GMR(123.5,GMRCSRVC,0),"^",1)
SET GMRCACT="MUP"
+18 SET ND=0
FOR
SET ND=$ORDER(^GMR(123.5,GMRCSRVC,2,ND))
IF ND?1A.E!(ND="")
QUIT
IF GMRCOLDS'=""&(^GMR(123.5,GMRCSRVC,2,ND,0)'="")
IF GMRCOLDS'[^GMR(123.5,GMRCSRVC,2,ND,0)
SET GMRCACT="MUP"
QUIT
+19 IF $SELECT(GMRCACT="MAD":1,GMRCACT="MUP":1,GMRCACT="MDC":1,1:0)
DO SVC^GMRC101H(GMRCSRVC,GMRCSSNM,GMRCACT)
DO MSG^XQOR("GMRC ORDERABLE ITEM UPDATE",.GMRCMSG)
+20 DO PTRCLN^GMRCU
+21 QUIT
End DoDot:1
+22 ;IHS/MSC/MGH Patch 1004 for Meaningful Use
+23 ;Find and/or add the SNOMED CONCEPT CT for this referral
+24 KILL ^TMP("GMRCSNO",$JOB),^TMP($JOB)
+25 NEW IN,OUT,DIC,X,CNT,CT,CCT,SNOMED,DIC,DIE,SCODE,VAR,DESC
+26 SET CT=0
SET DESC=""
+27 SET CCT=$$GET1^DIQ(123.5,GMRCSRVC,9999999.01)
+28 SET IN=CCT_"^30^^1"
+29 SET OUT="VAR"
+30 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+31 IF X>0
Begin DoDot:1
+32 SET DESC=$GET(VAR(1,"PRE","TRM"))
+33 IF DESC=""
SET DESC=CCT
End DoDot:1
+34 WRITE !!,"SNOMED Consult Type"
+35 WRITE !,"Current value is: "_DESC,!
+36 SET DIR(0)="Y"
SET DIR("A")="Would you like to edit"
+37 SET DIR("?")="Enter 'Yes' or 'No'"
DO ^DIR
KILL DIR
+38 IF $DATA(DTOUT)
QUIT
+39 IF X="Y"
Begin DoDot:1
+40 SET IN="EHR REFERRAL TYPE^30^1"
+41 SET OUT="^TMP(""GMRCSNO"",$J)"
+42 SET X=$$SUBLST^BSTSAPI(.OUT,.IN)
+43 SET CNT=""
FOR
SET CNT=$ORDER(@OUT@(CNT))
IF CNT=""
QUIT
Begin DoDot:2
+44 SET ^TMP($JOB,CNT,0)=$PIECE(@OUT@(CNT),U,3)
+45 SET ^TMP($JOB,"B",$PIECE(@OUT@(CNT),U,3))=CNT
+46 SET CT=CT+1
End DoDot:2
+47 SET ^TMP($JOB,0)=U_U_CT_U_CT
+48 WRITE !!,"Enter ? to see the list of SNOMED Consult Types"
+49 WRITE !,"Enter ^ to quit the selection",!
+50 SET DIC="^TMP($J,"
SET DIC(0)="AEQ"
SET DIC("A")="Select SNOMED TYPE: "
+51 SET DIC("B")=DESC
+52 DO ^DIC
+53 SET SNOMED=Y
+54 IF SNOMED'=-1
Begin DoDot:2
+55 KILL Y,DIE,DA,DR
+56 SET SCODE=$PIECE(^TMP("GMRCSNO",$JOB,$PIECE(SNOMED,U,1)),U,1)
+57 SET DIE="^GMR(123.5,"
SET DA=GMRCSRVC
SET DR="9999999.01///"_SCODE
+58 DO ^DIE
End DoDot:2
End DoDot:1
+59 ;end IHS MOD
+60 KILL GMRCMSG,GMRCSSNM,GMRCSRVS,GMRCOLDN,GMRCOLDS,GMRCOLDU,ND
+61 ;Ask to continue...
+62 ;
+63 NEW GMRC0,GMRCA,GMRCB,GMRCH,GMRCL
+64 SET GMRC0="YA"
SET GMRCA="Add/Edit Another Service? "
SET GMRCB="NO"
+65 SET GMRCH="Enter 'YES' to add/edit another service, or 'NO' to exit."
+66 SET GMRCL=2
+67 IF '+$$READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL)
DO END
QUIT
+68 GOTO EN
+69 ;
END KILL DIC,DIE,DTOUT,DUOUT,DA,DR,FL,GMRCACT,GMRCANS,GMRCMSG,GMRCREA,GMRCSRVC,GMRCSSNM,REVCODE,RLEVCODE,Y
+1 QUIT
+2 ;
READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL,GMRCS) ;
+1 ;
+2 ; GMRC0 -> DIR(0) --- Type of read
+3 ; GMRCA -> DIR("A") - Prompt
+4 ; GMRCB -> DIR("B") - Default Answer
+5 ; GMRCH -> DIR("?") - Help text or ^Execute code
+6 ; GMRCS -> DIR("S") - Screen
+7 ; GMRCL -> Number of blank lines to put before Prompt
+8 ;
+9 ; Returns "^" or answer
+10 ;
+11 NEW GMRCLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+12 IF '$LENGTH($GET(GMRC0))
QUIT U
+13 SET DIR(0)=GMRC0
+14 IF $LENGTH($GET(GMRCA))
SET DIR("A")=GMRCA
+15 IF $DATA(GMRCA("A"))
MERGE DIR("A")=GMRCA("A")
+16 IF $LENGTH($GET(GMRCB))
SET DIR("B")=GMRCB
+17 IF $DATA(GMRCH("?"))
MERGE DIR("?")=GMRCH("?")
+18 IF $LENGTH($GET(GMRCH))
SET DIR("?")=GMRCH
+19 IF $LENGTH($GET(GMRCS))
SET DIR("S")=GMRCS
+20 FOR GMRCLINE=1:1:($GET(GMRCL)-1)
WRITE !
+21 DO ^DIR
+22 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT U
+23 QUIT Y
+24 ;
NOED(SERV) ;
+1 IF '$DATA(^GMR(123.5,+SERV,0))
QUIT 0
+2 NEW NAME
+3 SET NAME=$PIECE(^GMR(123.5,+SERV,0),U)
+4 IF NAME="PROSTHETICS REQUEST"
QUIT 1
+5 IF NAME="EYEGLASS REQUEST"
QUIT 1
+6 IF NAME="CONTACT LENS REQUEST"
QUIT 1
+7 IF NAME="HOME OXYGEN REQUEST"
QUIT 1
+8 QUIT 0
+9 ;
CLONPSAS ; clone a PROSTHETICS service
+1 ; choose service and text to append
+2 NEW GMRCSIEN,GMRCROOT,GMRCNWNM
+3 NEW GMRCCPY,GMRCNEW,FDA,GMRCERR,GMRC
+4 SET GMRC(0)="PAO^GMR(123.5,:AEMQ"
+5 SET GMRC("A")="Select the Prosthetics Service to clone: "
+6 SET GMRC("S")="I $$NOED^GMRCSRVS(+Y)"
+7 SET GMRCCPY=+$$READ(GMRC(0),GMRC("A"),,,2,GMRC("S"))
+8 IF 'GMRCCPY
QUIT
+9 KILL GMRC
+10 SET GMRCNWNM=$$GETAPP(GMRCCPY)
+11 IF '$LENGTH(GMRCNWNM)
QUIT
+12 SET FDA(1,123.5,"+1,",.01)=GMRCNWNM
+13 SET FDA(1,123.5,"+1,",2)="DISABLED"
+14 SET FDA(1,123.5,"+1,",1.01)="REQUIRE"
+15 SET FDA(1,123.5,"+1,",1.02)="LEXICON"
+16 SET FDA(1,123.5,"+1,",123.01)="CONSULTS"
+17 SET FDA(1,123.5,"+1,",123.03)="GMRCACTM SERVICE ACTION MENU"
+18 SET FDA(1,123.5,"+1,",131)="YES"
+19 DO UPDATE^DIE("E","FDA(1)","GMRCNEW","GMRCERR")
+20 IF '$DATA(GMRCNEW)
WRITE !,"Failed to create new entry. Please try again"
QUIT
+21 WRITE !!,GMRCNWNM," created",!
+22 SET GMRCSIEN=GMRCNEW(1)_","
+23 SET GMRCROOT="^GMR(123.5,"_GMRCCPY_",124)"
+24 DO WP^DIE(123.5,GMRCSIEN,124,,GMRCROOT,"GMRCERR")
+25 WRITE !!,"The new Service is currently DISABLED. To activate this service for use in"
+26 WRITE !,"the Prosthetics interface, you MUST use the Setup Consult Services option"
+27 WRITE !,"and delete the DISABLED flag from the SERVICE USAGE field.",!
+28 QUIT
GETAPP(GMRIEN) ;get text to append
+1 NEW GMRCNWNM,QTFLG,I,GMRC,GMRCHL,OK
+2 SET GMRCNWNM=""
+3 FOR I=0:0
Begin DoDot:1
+4 WRITE !!
+5 SET GMRC(0)="FA^3:40"
+6 SET GMRC("A")="Enter text to append to national service name: "
+7 SET GMRCHL("?",1)="The text entered will be appended to the name of the exported service"
+8 SET GMRCHL("?")="(e.g. If HINES was entered it may appear as PROSTHETICS REQUEST - HINES"
+9 SET GMRCNWNM=$$READ(GMRC(0),GMRC("A"),,.GMRCHL,2)
+10 IF '$LENGTH(GMRCNWNM)!(GMRCNWNM["^")
SET GMRCNWNM=""
SET QTFLG=1
QUIT
+11 KILL GMRC,GMRCHL
+12 SET GMRCNWNM=$PIECE(^GMR(123.5,GMRIEN,0),U)_" - "_GMRCNWNM
+13 IF $$FIND1^DIC(123.5,,"X",GMRCNWNM)
Begin DoDot:2
+14 WRITE !!,$CHAR(7),"This service already exists, you'll have to try again!",!
+15 SET GMRCNWNM=""
End DoDot:2
QUIT
+16 WRITE !,"The new service name will be:"
+17 WRITE !,?5,GMRCNWNM,!
+18 SET OK=+$$READ("Y","Is this OK",,,1)
+19 IF OK=U
SET QTFLG=1
QUIT
+20 IF 'OK
SET GMRCNWNM=""
QUIT
+21 SET QTFLG=1
End DoDot:1
IF $GET(QTFLG)
QUIT
+22 QUIT GMRCNWNM
INPUT(X,GMRCDA) ; INPUT TRANSFORM FOR THE SUB-SERVICE/SPECIALTY (#.01) FIELD
+1 ; OF THE SUB-SERVICE (#123.51) FILE WHICH IS A SUB-FILE OF THE
+2 ; SUB-SERVICE (#10) FIELD OF THE REQUEST SERVICES (#123.5) FILE.
+3 ;
+4 ; X = INTERNAL VALUE OF USER SELECTED SUB-SERVICE (IEN OF SERVICE
+5 ; IN FILE 123.5)
+6 ; GMRCDA = IEN OF INITIAL PARENT SERVICE IN FILE 123.5
+7 ;
+8 IF +$GET(X)=0
KILL X
QUIT
+9 IF GMRCDA<1
Begin DoDot:1
+10 SET GMRCDA=+$GET(D0)
+11 IF GMRCDA<1
KILL X
End DoDot:1
IF '$DATA(X)
QUIT
+12 NEW GMRPARNT,GMRCHILD,GMRQ,GMRCNT
+13 ;MAKE SURE INPUT PARENT LOG GLOBAL IS BLANK
KILL ^TMP("GMRC INPUT",$JOB)
+14 ;NOT ALLOW SERVICE AS A SUB-SERVICE TO ITSELF
IF X=GMRCDA
SET GMRQ=1
GOTO INPUTQ
+15 ;USED TO PREVENT DUPLICATE CHECKING OF PARENTS
SET ^TMP("GMRC INPUT",$JOB,"B",GMRCDA)=""
+16 ;USED TO FIND NEXT NUMBER FOR TMP GLOBAL ENTRY
SET ^TMP("GMRC INPUT",$JOB,0)=1
+17 ;PARENT IEN STORED TO BE USED AS CHILD
SET ^TMP("GMRC INPUT",$JOB,1)=GMRCDA
+18 SET (GMRCNT,GMRQ)=0
+19 FOR
SET GMRCNT=$ORDER(^TMP("GMRC INPUT",$JOB,GMRCNT))
IF 'GMRCNT
QUIT
Begin DoDot:1
+20 SET GMRCHILD=$GET(^TMP("GMRC INPUT",$JOB,GMRCNT))
+21 SET GMRPARNT=0
+22 FOR
SET GMRPARNT=$ORDER(^GMR(123.5,"APC",GMRCHILD,GMRPARNT))
IF GMRPARNT=""
QUIT
Begin DoDot:2
+23 ;NOT ALLOW SERVICE AS A SUB-SERVICE WITHIN IT'S SUB-SERVICE HIERARCHY
IF GMRPARNT=X
SET GMRQ=1
QUIT
+24 ;IF NOT IN LIST ADD
IF '$DATA(^TMP("GMRC INPUT",$JOB,"B",GMRPARNT))
Begin DoDot:3
+25 ;ADD TO "B" CROSS-REFERENCE
SET ^TMP("GMRC INPUT",$JOB,"B",GMRPARNT)=""
+26 ;INCREASE LAST NUMBER BY 1
SET ^TMP("GMRC INPUT",$JOB,0)=$GET(^TMP("GMRC INPUT",$JOB,0))+1
+27 ;ADD NEW PARENT SERVICE TO GLOBAL SO IT CAN BE CHECKED AS A CHILD ENTRY TO FIND IT'S PARENTS
SET ^TMP("GMRC INPUT",$JOB,$GET(^TMP("GMRC INPUT",$JOB,0)))=GMRPARNT
End DoDot:3
End DoDot:2
IF GMRQ=1
QUIT
End DoDot:1
IF GMRQ=1
QUIT
+28 KILL ^TMP("GMRC INPUT",$JOB)
INPUTQ IF GMRQ=1
DO EN^DDIOL("A SERVICE CAN NOT BE A SUB-SERVICE OF ITSELF","","!!?12")
KILL X
QUIT
+1 ;
DUPCHK ;CHECK FOR CONSULT SERVICES APPEARING AS PART OF THE CONSULT SERVICE
+1 ;HIERARCHY IN MORE THAN ONE PLACE
+2 NEW ARRAY,COUNT,GMRCON,PARENT
+3 SET PARENT=0
+4 ;Check if they are a sub-service to more than one service.
+5 FOR COUNT=0:1
SET PARENT=$ORDER(^GMR(123.5,"APC",X,PARENT))
IF '+PARENT
QUIT
+6 ;Print message about which services this service is a sub-service of.
+7 IF COUNT'>0
QUIT
+8 SET COUNT=1
+9 SET ARRAY(COUNT)=" "
SET COUNT=COUNT+1
+10 SET ARRAY(COUNT)=" "
SET COUNT=COUNT+1
+11 SET ARRAY="Service "_$PIECE(^GMR(123.5,X,0),"^",1)_" is already a sub-service of:"
+12 DO PARSE(.ARRAY)
+13 SET PARENT=0
+14 FOR
SET PARENT=$ORDER(^GMR(123.5,"APC",X,PARENT))
IF '+PARENT
QUIT
SET ARRAY=" "_$PIECE(^GMR(123.5,PARENT,0),"^",1)
DO PARSE(.ARRAY)
+15 SET ARRAY(COUNT)=" "
SET COUNT=COUNT+1
+16 SET ARRAY(COUNT)="A consult service appearing as part of the Consult service"
SET COUNT=COUNT+1
+17 SET ARRAY(COUNT)="hierarchy in more than one place (i.e. a sub-service of more"
SET COUNT=COUNT+1
+18 SET ARRAY(COUNT)="than one parent) has the potential to skew the results of the"
SET COUNT=COUNT+1
+19 SET ARRAY(COUNT)="Consult Performance Monitor Report [GMRC RPT PERF MONITOR]."
SET COUNT=COUNT+1
+20 SET ARRAY(COUNT)=" "
SET COUNT=COUNT+1
+21 DO EN^DDIOL(.ARRAY)
+22 IF '$GET(DIQUIET)
Begin DoDot:1
+23 SET GMRCON=0
+24 DO YESNO(X,Y)
+25 IF 'GMRCON
KILL X
+26 DO EN^DDIOL(" ")
End DoDot:1
+27 QUIT
PARSE(ARRAY) ;TAKE ARRAY VALUE AND PARSE INTO PIECES SHORTER THAN 70 CHARACTERS
+1 NEW ARRAYSP,GMRCNT
PARSE1 IF $LENGTH(ARRAY)'>70
SET ARRAY(COUNT)=ARRAY
SET COUNT=COUNT+1
QUIT
+1 FOR GMRCNT=70:-1
SET ARRAYSP=$EXTRACT(ARRAY,GMRCNT)
IF ARRAYSP=" "
QUIT
+2 SET ARRAY(COUNT)=$EXTRACT(ARRAY,1,GMRCNT-1)
SET COUNT=COUNT+1
+3 SET ARRAY=$EXTRACT(ARRAY,GMRCNT+1,9999)
+4 IF ARRAY'=""
GOTO PARSE1
+5 QUIT
YESNO(X,Y) ;YES/NO QUESTION/RESPONSE
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="YA"
+3 SET DIR("A")="Do you wish to continue adding "_$PIECE(^GMR(123.5,X,0),"^",1)_" as a new sub-service? "
+4 SET DIR("B")="NO"
+5 SET DIR("T")=300
+6 SET DIR("?",1)="Enter ""YES"" to add service as a sub-service."
+7 SET DIR("?")="Enter ""NO"" to NOT add the service as a sub-service."
+8 DO ^DIR
IF ($GET(DTOUT))!($GET(DUOUT))!($GET(DIROUT))
QUIT
+9 IF Y=1
SET GMRCON=1
+10 QUIT
+11 ;IHS/MSC/MGH Patch 1004 See if the alert has a note
CONFIN(RET,XQAID) ;EP
+1 NEW TYPE,AIEN,FDA,IEN,ERR,ORY
+2 SET RET=""
SET ORY=""
+3 ;D GETDATA^ORWORB(.ORY,XQAID)
+4 SET ORY=$PIECE(XQAID,"|",1)
+5 IF $DATA(^GMR(123,+ORY,50))>1
Begin DoDot:1
+6 ;See if the viewer is the ordering provider
+7 IF DUZ=$$GET1^DIQ(123,+ORY,10,"I")
Begin DoDot:2
+8 ;DO LOOKUP INTO NEW FILE HERE
+9 FOR TYPE=371530004,371531000
Begin DoDot:3
+10 SET AIEN="+1,"_+ORY_","
+11 SET FDA(123.999999911,AIEN,.01)=TYPE
+12 SET FDA(123.999999911,AIEN,2)=$$NOW^XLFDT
+13 SET FDA(123.999999911,AIEN,1)=DUZ
+14 DO UPDATE^DIE(,"FDA","IEN","ERR")
+15 IF $DATA(ERR)
SET RET="-1^Error on storing SNOMED terms"
+16 IF '$TEST
SET RET=0
+17 KILL FDA,IEN,ERR
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
IND() ;Change choices on clin indication
+1 NEW DIR,Y,DEF
+2 SET DIR(0)="SO^O:Optional"
+3 SET DIR("A")="CLINICAL INDICATION"
+4 SET DIR("B")=$SELECT($PIECE($GET(^GMR(123.5,DA,1)),"^",1)="O":"O",1:"")
+5 SET DIR("?")="Enter O if clinical indication is optional, otherwise required."
+6 DO ^DIR
+7 IF Y=""
SET Y="@"
+8 QUIT Y
