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. ;6/14/00 12:00
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**1,16,40,53,63,186,191**;DEC 27, 1997;Build 17
  1.  ;
  1.  ;Jan 5, 2022, Phil Burkhalter - patch GMRC*3.0*186, added code to edit the Community Care Clinic filed if the consult service is for a community care consult
  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 SERVICE]",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.  ;Phil Burkhalter - Jan 10, 2022 patch GMRC*3.0*186 - Change to edit the Related Hospital Location to add a community care clinic
  1.  I $P(^GMR(123.5,GMRCSRVC,0),"^")["COMMUNITY CARE" D
  1.  .N XY,CLIN,CLINNAME,LAST S (LAST,XY)=0 F  S XY=$O(^GMR(123.5,GMRCSRVC,123.4,XY)) Q:XY'>0  S LAST=XY
  1.  .I $G(LAST)'>0 D
  1.  ..N DIC,Y,X,DLAYGO,DUOUT,DTOUT,CCCLINIC S DIC="^SC(",DIC(0)="QEAB",DIC("S")="I $P(^SC(Y,0),U)[""COM CARE"""
  1.  ..D ^DIC I $S(Y<0:1,$D(DTOUT):1,$D(DUOUT):1,1:0) K DTOUT,DUOUT,X,Y Q  ;G ASK
  1.  ..S CCCLINIC=+Y
  1.  ..;add a new entry so it will be the last entry.
  1.  ..;routine SDECCRSEN loops thru this multiple and get the last clinic in the list.
  1.  ..;the SDCCRSEN routine, when pulling the clinic, checks the clinic name to make sure it is a com care clinic
  1.  ..;if it is not a com care clinic don't use it for scheduling, default to the existing match rules in SDCCRSEN
  1.  ..N SUBREC,REC S (REC,SUBREC)=0 F  S SUBREC=$O(^GMR(123.5,GMRCSRVC,123.4,SUBREC)) Q:$G(SUBREC)'>0  S REC=SUBREC
  1.  ..N FDA,FDAIEN S FDAIEN="+1,"_GMRCSRVC_",",FDA(1,123.56,FDAIEN,.01)=CCCLINIC D UPDATE^DIE("","FDA(1)")
  1.  .I $G(LAST)>0 D
  1.  ..S CLIN=$P(^GMR(123.5,GMRCSRVC,123.4,LAST,0),"^"),CLINNAME=$P(^SC(CLIN,0),"^")
  1.  ..N DIE,DR,DA,X,Y S DA=LAST,DA(1)=GMRCSRVC,DIE="^GMR(123.5,"_DA(1)_",123.4,",DR=".01//"_CLINNAME D ^DIE
  1.  ;end patch GMRC*3.0*186 changes
  1. ASK ; 
  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