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

GMRCSRVS.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. 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).
  1.  N GMRCSAFE,GMRCOLDU,GMRCOLDS,GMRCOSNM,GMRCSRVC,GMRCACT,GMRCSSNM
  1.  N DIC,DLAYGO,DUOUT,DTOUT
  1.  S DIC="^GMR(123.5,",DLAYGO=123.5,DIC(0)="AELMQZ",DIC("A")="Select Service/Specialty:"
  1.  D ^DIC I $S(Y<0:1,$D(DTOUT):1,$D(DUOUT):1,1:0) D END K GMRCMSG,DTOUT,DUOUT Q
  1.  D
  1.  .S GMRCSAFE=+$G(^GMR(123.5,+Y,"INT"))
  1.  .S (DA,GMRCSRVC)=+Y,GMRCOSNM=$P(Y,"^",2),(GMRCOLDU,GMRCOLDS)=""
  1.  .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)_"^"
  1.  .S DIE=DIC,DR="[GMRC SETUP REQUEST MU]",DIE("NO^")="OUTOK"
  1.  .D ^DIE
  1.  .Q
  1.  I $D(DA) S GMRCACT=$S($P(^GMR(123.5,GMRCSRVC,0),"^",2)=9:"MDC",$P(^(0),"^",2)=1:"MDC",1:GMRCACT) D
  1.  .S GMRCSSNM=$P(^GMR(123.5,GMRCSRVC,0),"^",1)
  1.  .I GMRCACT'="MAD",GMRCSSNM'=GMRCOSNM S GMRCACT="MUP"
  1.  .I $S(GMRCACT'="MAD":1,GMRCACT'="MUP":1,1:0),$L(GMRCOLDU),GMRCOLDU=$P(^GMR(123.5,GMRCSRVC,0),"^",2) S GMRCACT="NOACT"
  1.  .I $S(GMRCACT="MUP":1,GMRCACT="NOACT":1,1:0),GMRCOLDN'=$P(^GMR(123.5,GMRCSRVC,0),"^",1) S GMRCACT="MUP"
  1.  .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
  1.  .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)
  1.  .D PTRCLN^GMRCU
  1.  .Q
  1.  ;IHS/MSC/MGH Patch 1004 for Meaningful Use
  1.  ;Find and/or add the SNOMED CONCEPT CT for this referral
  1.  K ^TMP("GMRCSNO",$J),^TMP($J)
  1.  N IN,OUT,DIC,X,CNT,CT,CCT,SNOMED,DIC,DIE,SCODE,VAR,DESC
  1.  S CT=0,DESC=""
  1.  S CCT=$$GET1^DIQ(123.5,GMRCSRVC,9999999.01)
  1.  S IN=CCT_"^30^^1"
  1.  S OUT="VAR"
  1.  S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
  1.  I X>0 D
  1.  .S DESC=$G(VAR(1,"PRE","TRM"))
  1.  .I DESC="" S DESC=CCT
  1.  W !!,"SNOMED Consult Type"
  1.  W !,"Current value is: "_DESC,!
  1.  S DIR(0)="Y",DIR("A")="Would you like to edit"
  1.  S DIR("?")="Enter 'Yes' or 'No'" D ^DIR K DIR
  1.  Q:$D(DTOUT)
  1.  I X="Y" D
  1.  .S IN="EHR REFERRAL TYPE^30^1"
  1.  .S OUT="^TMP(""GMRCSNO"",$J)"
  1.  .S X=$$SUBLST^BSTSAPI(.OUT,.IN)
  1.  .S CNT="" F  S CNT=$O(@OUT@(CNT)) Q:CNT=""  D
  1.  ..S ^TMP($J,CNT,0)=$P(@OUT@(CNT),U,3)
  1.  ..S ^TMP($J,"B",$P(@OUT@(CNT),U,3))=CNT
  1.  ..S CT=CT+1
  1.  .S ^TMP($J,0)=U_U_CT_U_CT
  1.  .W !!,"Enter ? to see the list of SNOMED Consult Types"
  1.  .W !,"Enter ^ to quit the selection",!
  1.  .S DIC="^TMP($J," S DIC(0)="AEQ",DIC("A")="Select SNOMED TYPE: "
  1.  .S DIC("B")=DESC
  1.  .D ^DIC
  1.  .S SNOMED=Y
  1.  .I SNOMED'=-1 D
  1.  ..K Y,DIE,DA,DR
  1.  ..S SCODE=$P(^TMP("GMRCSNO",$J,$P(SNOMED,U,1)),U,1)
  1.  ..S DIE="^GMR(123.5,",DA=GMRCSRVC,DR="9999999.01///"_SCODE
  1.  ..D ^DIE
  1.  ;end IHS MOD
  1.  K GMRCMSG,GMRCSSNM,GMRCSRVS,GMRCOLDN,GMRCOLDS,GMRCOLDU,ND
  1.  ;Ask to continue...
  1.  ;
  1.  N GMRC0,GMRCA,GMRCB,GMRCH,GMRCL
  1.  S GMRC0="YA",GMRCA="Add/Edit Another Service? ",GMRCB="NO"
  1.  S GMRCH="Enter 'YES' to add/edit another service, or 'NO' to exit."
  1.  S GMRCL=2
  1.  I '+$$READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL) D END Q
  1.  G EN
  1.  ;
  1. END K DIC,DIE,DTOUT,DUOUT,DA,DR,FL,GMRCACT,GMRCANS,GMRCMSG,GMRCREA,GMRCSRVC,GMRCSSNM,REVCODE,RLEVCODE,Y
  1.  Q
  1.  ;
  1. READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL,GMRCS) ;
  1.  ;
  1.  ;  GMRC0 -> DIR(0) --- Type of read
  1.  ;  GMRCA -> DIR("A") - Prompt
  1.  ;  GMRCB -> DIR("B") - Default Answer
  1.  ;  GMRCH -> DIR("?") - Help text or ^Execute code
  1.  ;  GMRCS -> DIR("S") - Screen
  1.  ;  GMRCL -> Number of blank lines to put before Prompt
  1.  ;
  1.  ;  Returns "^" or answer
  1.  ;
  1.  N GMRCLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
  1.  Q:'$L($G(GMRC0)) U
  1.  S DIR(0)=GMRC0
  1.  S:$L($G(GMRCA)) DIR("A")=GMRCA
  1.  I $D(GMRCA("A")) M DIR("A")=GMRCA("A")
  1.  S:$L($G(GMRCB)) DIR("B")=GMRCB
  1.  I $D(GMRCH("?")) M DIR("?")=GMRCH("?")
  1.  S:$L($G(GMRCH)) DIR("?")=GMRCH
  1.  S:$L($G(GMRCS)) DIR("S")=GMRCS
  1.  F GMRCLINE=1:1:($G(GMRCL)-1) W !
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
  1.  Q Y
  1.  ;
  1. NOED(SERV) ;
  1.  I '$D(^GMR(123.5,+SERV,0)) Q 0
  1.  N NAME
  1.  S NAME=$P(^GMR(123.5,+SERV,0),U)
  1.  I NAME="PROSTHETICS REQUEST" Q 1
  1.  I NAME="EYEGLASS REQUEST" Q 1
  1.  I NAME="CONTACT LENS REQUEST" Q 1
  1.  I NAME="HOME OXYGEN REQUEST" Q 1
  1.  Q 0
  1.  ;
  1. CLONPSAS ; clone a PROSTHETICS service
  1.  ; choose service and text to append
  1.  N GMRCSIEN,GMRCROOT,GMRCNWNM
  1.  N GMRCCPY,GMRCNEW,FDA,GMRCERR,GMRC
  1.  S GMRC(0)="PAO^GMR(123.5,:AEMQ"
  1.  S GMRC("A")="Select the Prosthetics Service to clone: "
  1.  S GMRC("S")="I $$NOED^GMRCSRVS(+Y)"
  1.  S GMRCCPY=+$$READ(GMRC(0),GMRC("A"),,,2,GMRC("S"))
  1.  I 'GMRCCPY Q
  1.  K GMRC
  1.  S GMRCNWNM=$$GETAPP(GMRCCPY)
  1.  I '$L(GMRCNWNM) Q
  1.  S FDA(1,123.5,"+1,",.01)=GMRCNWNM
  1.  S FDA(1,123.5,"+1,",2)="DISABLED"
  1.  S FDA(1,123.5,"+1,",1.01)="REQUIRE"
  1.  S FDA(1,123.5,"+1,",1.02)="LEXICON"
  1.  S FDA(1,123.5,"+1,",123.01)="CONSULTS"
  1.  S FDA(1,123.5,"+1,",123.03)="GMRCACTM SERVICE ACTION MENU"
  1.  S FDA(1,123.5,"+1,",131)="YES"
  1.  D UPDATE^DIE("E","FDA(1)","GMRCNEW","GMRCERR")
  1.  I '$D(GMRCNEW) W !,"Failed to create new entry. Please try again" Q
  1.  W !!,GMRCNWNM," created",!
  1.  S GMRCSIEN=GMRCNEW(1)_","
  1.  S GMRCROOT="^GMR(123.5,"_GMRCCPY_",124)"
  1.  D WP^DIE(123.5,GMRCSIEN,124,,GMRCROOT,"GMRCERR")
  1.  W !!,"The new Service is currently DISABLED. To activate this service for use in"
  1.  W !,"the Prosthetics interface, you MUST use the Setup Consult Services option"
  1.  W !,"and delete the DISABLED flag from the SERVICE USAGE field.",!
  1.  Q
  1. GETAPP(GMRIEN) ;get text to append
  1.  N GMRCNWNM,QTFLG,I,GMRC,GMRCHL,OK
  1.  S GMRCNWNM=""
  1.  F I=0:0 D  Q:$G(QTFLG)
  1.  . W !!
  1.  . S GMRC(0)="FA^3:40"
  1.  . S GMRC("A")="Enter text to append to national service name: "
  1.  . S GMRCHL("?",1)="The text entered will be appended to the name of the exported service"
  1.  . S GMRCHL("?")="(e.g. If HINES was entered it may appear as PROSTHETICS REQUEST - HINES"
  1.  . S GMRCNWNM=$$READ(GMRC(0),GMRC("A"),,.GMRCHL,2)
  1.  . I '$L(GMRCNWNM)!(GMRCNWNM["^") S GMRCNWNM="",QTFLG=1 Q
  1.  . K GMRC,GMRCHL
  1.  . S GMRCNWNM=$P(^GMR(123.5,GMRIEN,0),U)_" - "_GMRCNWNM
  1.  . I $$FIND1^DIC(123.5,,"X",GMRCNWNM) D  Q
  1.  .. W !!,$C(7),"This service already exists, you'll have to try again!",!
  1.  .. S GMRCNWNM=""
  1.  . W !,"The new service name will be:"
  1.  . W !,?5,GMRCNWNM,!
  1.  . S OK=+$$READ("Y","Is this OK",,,1)
  1.  . I OK=U S QTFLG=1 Q
  1.  . I 'OK S GMRCNWNM="" Q
  1.  . S QTFLG=1
  1.  Q GMRCNWNM
  1. 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
  1.  ; SUB-SERVICE (#10) FIELD OF THE REQUEST SERVICES (#123.5) FILE.
  1.  ;
  1.  ; X = INTERNAL VALUE OF USER SELECTED SUB-SERVICE (IEN OF SERVICE
  1.  ;     IN FILE 123.5)
  1.  ; GMRCDA = IEN OF INITIAL PARENT SERVICE IN FILE 123.5
  1.  ;
  1.  I +$G(X)=0 K X Q
  1.  I GMRCDA<1 D  Q:'$D(X)
  1.  . S GMRCDA=+$G(D0)
  1.  . I GMRCDA<1 K X
  1.  N GMRPARNT,GMRCHILD,GMRQ,GMRCNT
  1.  K ^TMP("GMRC INPUT",$J) ;MAKE SURE INPUT PARENT LOG GLOBAL IS BLANK
  1.  I X=GMRCDA S GMRQ=1 G INPUTQ ;NOT ALLOW SERVICE AS A SUB-SERVICE TO ITSELF
  1.  S ^TMP("GMRC INPUT",$J,"B",GMRCDA)="" ;USED TO PREVENT DUPLICATE CHECKING OF PARENTS
  1.  S ^TMP("GMRC INPUT",$J,0)=1 ;USED TO FIND NEXT NUMBER FOR TMP GLOBAL ENTRY
  1.  S ^TMP("GMRC INPUT",$J,1)=GMRCDA ;PARENT IEN STORED TO BE USED AS CHILD
  1.  S (GMRCNT,GMRQ)=0
  1.  F  S GMRCNT=$O(^TMP("GMRC INPUT",$J,GMRCNT)) Q:'GMRCNT  D  Q:GMRQ=1
  1.  . S GMRCHILD=$G(^TMP("GMRC INPUT",$J,GMRCNT))
  1.  . S GMRPARNT=0
  1.  . F  S GMRPARNT=$O(^GMR(123.5,"APC",GMRCHILD,GMRPARNT)) Q:GMRPARNT=""  D  Q:GMRQ=1
  1.  .. I GMRPARNT=X S GMRQ=1 Q  ;NOT ALLOW SERVICE AS A SUB-SERVICE WITHIN IT'S SUB-SERVICE HIERARCHY
  1.  .. I '$D(^TMP("GMRC INPUT",$J,"B",GMRPARNT)) D  ;IF NOT IN LIST ADD
  1.  ... S ^TMP("GMRC INPUT",$J,"B",GMRPARNT)="" ;ADD TO "B" CROSS-REFERENCE
  1.  ... S ^TMP("GMRC INPUT",$J,0)=$G(^TMP("GMRC INPUT",$J,0))+1 ;INCREASE LAST NUMBER BY 1
  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
  1.  K ^TMP("GMRC INPUT",$J)
  1. INPUTQ I GMRQ=1 D EN^DDIOL("A SERVICE CAN NOT BE A SUB-SERVICE OF ITSELF","","!!?12") K X Q
  1.  ;
  1. DUPCHK ;CHECK FOR CONSULT SERVICES APPEARING AS PART OF THE CONSULT SERVICE
  1.  ;HIERARCHY IN MORE THAN ONE PLACE
  1.  N ARRAY,COUNT,GMRCON,PARENT
  1.  S PARENT=0
  1.  ;Check if they are a sub-service to more than one service.
  1.  F COUNT=0:1 S PARENT=$O(^GMR(123.5,"APC",X,PARENT)) Q:'+PARENT
  1.  ;Print message about which services this service is a sub-service of.
  1.  I COUNT'>0 Q
  1.  S COUNT=1
  1.  S ARRAY(COUNT)=" ",COUNT=COUNT+1
  1.  S ARRAY(COUNT)=" ",COUNT=COUNT+1
  1.  S ARRAY="Service "_$P(^GMR(123.5,X,0),"^",1)_" is already a sub-service of:"
  1.  D PARSE(.ARRAY)
  1.  S PARENT=0
  1.  F  S PARENT=$O(^GMR(123.5,"APC",X,PARENT)) Q:'+PARENT  S ARRAY="   "_$P(^GMR(123.5,PARENT,0),"^",1) D PARSE(.ARRAY)
  1.  S ARRAY(COUNT)=" ",COUNT=COUNT+1
  1.  S ARRAY(COUNT)="A consult service appearing as part of the Consult service",COUNT=COUNT+1
  1.  S ARRAY(COUNT)="hierarchy in more than one place (i.e. a sub-service of more",COUNT=COUNT+1
  1.  S ARRAY(COUNT)="than one parent) has the potential to skew the results of the",COUNT=COUNT+1
  1.  S ARRAY(COUNT)="Consult Performance Monitor Report [GMRC RPT PERF MONITOR].",COUNT=COUNT+1
  1.  S ARRAY(COUNT)=" ",COUNT=COUNT+1
  1.  D EN^DDIOL(.ARRAY)
  1.  I '$G(DIQUIET) D
  1.  . S GMRCON=0
  1.  . D YESNO(X,Y)
  1.  . I 'GMRCON K X
  1.  . D EN^DDIOL(" ")
  1.  Q
  1. PARSE(ARRAY) ;TAKE ARRAY VALUE AND PARSE INTO PIECES SHORTER THAN 70 CHARACTERS
  1.  N ARRAYSP,GMRCNT
  1. PARSE1 I $L(ARRAY)'>70 S ARRAY(COUNT)=ARRAY,COUNT=COUNT+1 Q
  1.  F GMRCNT=70:-1 S ARRAYSP=$E(ARRAY,GMRCNT) I ARRAYSP=" " Q
  1.  S ARRAY(COUNT)=$E(ARRAY,1,GMRCNT-1),COUNT=COUNT+1
  1.  S ARRAY=$E(ARRAY,GMRCNT+1,9999)
  1.  G:ARRAY'="" PARSE1
  1.  Q
  1. YESNO(X,Y) ;YES/NO QUESTION/RESPONSE
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1.  S DIR(0)="YA"
  1.  S DIR("A")="Do you wish to continue adding "_$P(^GMR(123.5,X,0),"^",1)_" as a new sub-service? "
  1.  S DIR("B")="NO"
  1.  S DIR("T")=300
  1.  S DIR("?",1)="Enter ""YES"" to add service as a sub-service."
  1.  S DIR("?")="Enter ""NO"" to NOT add the service as a sub-service."
  1.  D ^DIR Q:($G(DTOUT))!($G(DUOUT))!($G(DIROUT))
  1.  I Y=1 S GMRCON=1
  1.  Q
  1.  ;IHS/MSC/MGH Patch 1004 See if the alert has a note
  1. CONFIN(RET,XQAID) ;EP
  1.  N TYPE,AIEN,FDA,IEN,ERR,ORY
  1.  S RET="",ORY=""
  1.  ;D GETDATA^ORWORB(.ORY,XQAID)
  1.  S ORY=$P(XQAID,"|",1)
  1.  I $D(^GMR(123,+ORY,50))>1 D
  1.  .;See if the viewer is the ordering provider
  1.  .I DUZ=$$GET1^DIQ(123,+ORY,10,"I") D
  1.  ..;DO LOOKUP INTO NEW FILE HERE
  1.  ..F TYPE=371530004,371531000 D
  1.  ...S AIEN="+1,"_+ORY_","
  1.  ...S FDA(123.999999911,AIEN,.01)=TYPE
  1.  ...S FDA(123.999999911,AIEN,2)=$$NOW^XLFDT
  1.  ...S FDA(123.999999911,AIEN,1)=DUZ
  1.  ...D UPDATE^DIE(,"FDA","IEN","ERR")
  1.  ...I $D(ERR) S RET="-1^Error on storing SNOMED terms"
  1.  ...E  S RET=0
  1.  ...K FDA,IEN,ERR
  1.  Q
  1. IND() ;Change choices on clin indication
  1.  N DIR,Y,DEF
  1.  S DIR(0)="SO^O:Optional"
  1.  S DIR("A")="CLINICAL INDICATION"
  1.  S DIR("B")=$S($P($G(^GMR(123.5,DA,1)),"^",1)="O":"O",1:"")
  1.  S DIR("?")="Enter O if clinical indication is optional, otherwise required."
  1.  D ^DIR
  1.  I Y="" S Y="@"
  1.  Q Y