GMRCUTL1 ;SLC/DCM,JFR,MA - General Utilities ;04/27/2017 15:23
;;3.0;CONSULT/REQUEST TRACKING;**1,4,12,15,21,17,28,89,96**;DEC 27, 1997;Build 21
; Added call to GMRCUTL2 for secondary printer
; This routine invokes IA #2876,3121
; Patch #21 added variable GMRCAUDT and moved line tag PRNTAUDT
; to GMRCP5A.
;
; ABV/SCR - 12/14/2017 added tag NEWUCID for patch number TBD to return the UniqueConsultID which is added to
; ORIGINAL records (records created through CPRS)
;
ACTM ;;Set correct variables to complete, discontinue, etc. a consult
K GMRCQUT
S:'+$G(GMRCA) GMRCA=$O(^GMR(123.1,"B",GMRCACTM,""))
S GMRCACTM=$P($G(^GMR(123.1,+GMRCA,0)),"^")
S ORSTS=$S(GMRCA:$P(^GMR(123.1,GMRCA,0),"^",2),1:0)
I 'GMRCA S GMRCQUT=1
Q
PRNT(SRVCIFN,GMRCO) ;print form 513 to a printer when new consult is entered
D PRNT^GMRCUTL2(SRVCIFN,GMRCO) ;89 call for secondary copy
N ORVP,GMRCDEV,GMRCQUED,IOP,%ZIS,POP,ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,GMRCAUDT
I '$G(SRVCIFN) S SRVCIFN=+$P(^GMR(123,GMRCO,0),U,5)
Q:'$D(^GMR(123.5,SRVCIFN,123)) Q:'$P(^GMR(123.5,SRVCIFN,123),"^",9)
S IOP="`"_$P(^GMR(123.5,SRVCIFN,123),"^",9)
S %ZIS="N" D ^%ZIS I POP S %ZIS=0 D HOME^%ZIS Q
S GMRCDEV=ION,GMRCQUED=1,GMRCAUDT=1
S ZTRTN="PRNT^GMRCP5A("_(+GMRCO)_","_(+$G(TIUFLG))_",1,"""_$G(GMRCCPY,"W")_""",0,"_(GMRCAUDT)_")"
S ZTDESC="CONSULT/REQUEST PACKAGE PRINT FORM 513 FOR NEW CONSULT"
S ZTIO=GMRCDEV,ZTDTH=$H
D ^%ZTLOAD
S %ZIS=0 D HOME^%ZIS
K GMRCQUED,GMRCDEV1
Q
END K GMRCDEV,GMRCDEV1,GMRCOREC,GMRCFMT
Q
PROVDX(OI) ;return PROV DX prompting info from 123.5
; Input:
; OI = ref to file 123.5("#;99CON") or file 123.3 (#;99PRC)
;
; Returns: string A^B
; A = O (optional), R (required) or S (suppress)
; B = F (free-text) or L (lexicon)
;
N GMRCFIL
Q:'+$G(OI) "^"
S GMRCFIL=$S(OI["99PRC":123.3,1:123.5)
Q:'$D(^GMR(GMRCFIL,+OI)) "^"
N STRING,NODE
I GMRCFIL=123.3 S NODE=$P(^GMR(123.3,+OI,0),U,7,8)
I GMRCFIL=123.5 S NODE=$P($G(^GMR(123.5,+OI,1)),U,1,2)
I NODE="" Q "O^F" ;values not set
S $P(STRING,U)=$S($L($P(NODE,U)):$P(NODE,U),1:"O")
S $P(STRING,U,2)=$S($L($P(NODE,U,2)):$P(NODE,U,2),1:"F")
Q STRING
ORIFN(GMRC123) ;return ORIFN associated with give record in ^GMR(123,
; GMRC123 = ien of consult record in file 123
Q $P($G(^GMR(123,GMRC123,0)),U,3)
GETDT(PROMPT,DEFAULT) ;prompt and return FM date
;Input:
; PROMPT = text of prompt - DIR("A") (optional)
; DEFAULT = default date to prompt - DIR("B") (optional)
;
;Output:
; FM date/time if successfully answered, "^" if exit or timeout
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
S DIR(0)="DA^::EPT"
S DIR("?")="Enter the date/time the activity took place."
S DIR("A")=$S($D(PROMPT):PROMPT_" ",1:"Actual Date/Time of Activity: ")
S DIR("B")=$S($D(DEFAULT):DEFAULT,1:"NOW")
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S Y="^"
Q Y
;
DCPRNT(IEN,USER) ;reprint SF-513 on DC?
N SERV,REPR
S SERV=$P(^GMR(123,IEN,0),U,5) I 'SERV Q 0
S REPR=$P($G(^GMR(123.5,SERV,1)),U,5)
I 'REPR Q 1
I REPR=2 Q 0
I REPR=1,'$$VALID^GMRCAU(SERV,IEN,USER) Q 1
Q 0
;
PREREQ(GMRCARR,GMRCSRV,GMRCDFN,UNRESOLV) ; return service pre-requisite
; pre-requisite stored in 125 nodes in file 123.5 or 123.3
; GMRCARR = array to return containing pre-requisite
; GMRCSRV = ref to file 123.5 (ien;99CON) or 123.3 (ien;99PRC)
; GMRCDFN = patient identifier if to return resolved
; UNRESOLV = 1 or 0 ; if UNRESOLV=1 GMRCARR will be returned unresolved
Q:'+GMRCSRV
N GMRCFIL
S GMRCFIL=$S(GMRCSRV["99PRC":123.3,1:123.5)
Q:'$D(^GMR(GMRCFIL,+GMRCSRV,125))
I '$D(GMRCDFN)!($G(UNRESOLV)) D Q
. M @GMRCARR=^GMR(GMRCFIL,+GMRCSRV,125)
D BLRPLT^TIUSRVD(,,GMRCDFN,,$NA(^GMR(GMRCFIL,+GMRCSRV,125)))
I $D(^TMP("TIUBOIL",$J)) M @GMRCARR=^TMP("TIUBOIL",$J)
K ^TMP("TIUBOIL",$J)
Q
;
LOCKREC(GMRCDA) ;attempt to lock a consult record using order or record
; Input:
; GMRCDA = ien of consult record from file 123
;
; Output:
; 1 or 0^reason can't be locked
; 1 = successfully locked
; 0 = couldn't be locked
N GMRCORD,GMRCMSG
S GMRCORD=$P($G(^GMR(123,GMRCDA,0)),U,3)
I $G(GMRCORD) D ;an order associated
. S GMRCMSG=$$LOCK1^ORX2(GMRCORD)
. ; GMRCMSG=1 if locked or 0 if couldn't be locked
I $L($G(GMRCMSG)) Q GMRCMSG
; no order = Inter-facility Consult so lock consult record
L +^GMR(123,GMRCDA):5
I '$T Q "0^Another user is editing this record" ; couldn't lock it
Q 1
;
UNLKREC(GMRCDA) ;unlock a consult record
; Input:
; GMRCDA = ien of consult record from file 123
;
N GMRCORD
S GMRCORD=$P($G(^GMR(123,GMRCDA,0)),U,3)
I $G(GMRCORD) D Q
. D UNLK1^ORX2(GMRCORD)
L -^GMR(123,GMRCDA)
Q
;ABV/SCR 12/14/2017 added sub-routine to generate new field #80 - UCID for *96*
NEWUCID(GMRCIEN) ;return a string that uniquely identifies this record accross VistAs
; INPUT:
; GMRCIEN ien of consult/request record from file 123
;
N GMRCSTA,GMRCSTRN
;
;Validate the GMRCIEN exists
S GMRCSTRN=""
I $G(^GMR(123,$G(GMRCIEN),0))'="" D
.S GMRCSTA=$$GET^XPAR("PKG","GMRC UNIQUE CONSULT SITE ID",,"E") ;RETURNS THE EXTERNAL VALUE OF THE PARAMETER
.S:GMRCSTA GMRCSTRN=GMRCSTA_"_"_GMRCIEN
Q GMRCSTRN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCUTL1 5274 printed Sep 23, 2025@19:23:47 Page 2
GMRCUTL1 ;SLC/DCM,JFR,MA - General Utilities ;04/27/2017 15:23
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,12,15,21,17,28,89,96**;DEC 27, 1997;Build 21
+2 ; Added call to GMRCUTL2 for secondary printer
+3 ; This routine invokes IA #2876,3121
+4 ; Patch #21 added variable GMRCAUDT and moved line tag PRNTAUDT
+5 ; to GMRCP5A.
+6 ;
+7 ; ABV/SCR - 12/14/2017 added tag NEWUCID for patch number TBD to return the UniqueConsultID which is added to
+8 ; ORIGINAL records (records created through CPRS)
+9 ;
ACTM ;;Set correct variables to complete, discontinue, etc. a consult
+1 KILL GMRCQUT
+2 if '+$GET(GMRCA)
SET GMRCA=$ORDER(^GMR(123.1,"B",GMRCACTM,""))
+3 SET GMRCACTM=$PIECE($GET(^GMR(123.1,+GMRCA,0)),"^")
+4 SET ORSTS=$SELECT(GMRCA:$PIECE(^GMR(123.1,GMRCA,0),"^",2),1:0)
+5 IF 'GMRCA
SET GMRCQUT=1
+6 QUIT
PRNT(SRVCIFN,GMRCO) ;print form 513 to a printer when new consult is entered
+1 ;89 call for secondary copy
DO PRNT^GMRCUTL2(SRVCIFN,GMRCO)
+2 NEW ORVP,GMRCDEV,GMRCQUED,IOP,%ZIS,POP,ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,GMRCAUDT
+3 IF '$GET(SRVCIFN)
SET SRVCIFN=+$PIECE(^GMR(123,GMRCO,0),U,5)
+4 if '$DATA(^GMR(123.5,SRVCIFN,123))
QUIT
if '$PIECE(^GMR(123.5,SRVCIFN,123),"^",9)
QUIT
+5 SET IOP="`"_$PIECE(^GMR(123.5,SRVCIFN,123),"^",9)
+6 SET %ZIS="N"
DO ^%ZIS
IF POP
SET %ZIS=0
DO HOME^%ZIS
QUIT
+7 SET GMRCDEV=ION
SET GMRCQUED=1
SET GMRCAUDT=1
+8 SET ZTRTN="PRNT^GMRCP5A("_(+GMRCO)_","_(+$GET(TIUFLG))_",1,"""_$GET(GMRCCPY,"W")_""",0,"_(GMRCAUDT)_")"
+9 SET ZTDESC="CONSULT/REQUEST PACKAGE PRINT FORM 513 FOR NEW CONSULT"
+10 SET ZTIO=GMRCDEV
SET ZTDTH=$HOROLOG
+11 DO ^%ZTLOAD
+12 SET %ZIS=0
DO HOME^%ZIS
+13 KILL GMRCQUED,GMRCDEV1
+14 QUIT
END KILL GMRCDEV,GMRCDEV1,GMRCOREC,GMRCFMT
+1 QUIT
PROVDX(OI) ;return PROV DX prompting info from 123.5
+1 ; Input:
+2 ; OI = ref to file 123.5("#;99CON") or file 123.3 (#;99PRC)
+3 ;
+4 ; Returns: string A^B
+5 ; A = O (optional), R (required) or S (suppress)
+6 ; B = F (free-text) or L (lexicon)
+7 ;
+8 NEW GMRCFIL
+9 if '+$GET(OI)
QUIT "^"
+10 SET GMRCFIL=$SELECT(OI["99PRC":123.3,1:123.5)
+11 if '$DATA(^GMR(GMRCFIL,+OI))
QUIT "^"
+12 NEW STRING,NODE
+13 IF GMRCFIL=123.3
SET NODE=$PIECE(^GMR(123.3,+OI,0),U,7,8)
+14 IF GMRCFIL=123.5
SET NODE=$PIECE($GET(^GMR(123.5,+OI,1)),U,1,2)
+15 ;values not set
IF NODE=""
QUIT "O^F"
+16 SET $PIECE(STRING,U)=$SELECT($LENGTH($PIECE(NODE,U)):$PIECE(NODE,U),1:"O")
+17 SET $PIECE(STRING,U,2)=$SELECT($LENGTH($PIECE(NODE,U,2)):$PIECE(NODE,U,2),1:"F")
+18 QUIT STRING
ORIFN(GMRC123) ;return ORIFN associated with give record in ^GMR(123,
+1 ; GMRC123 = ien of consult record in file 123
+2 QUIT $PIECE($GET(^GMR(123,GMRC123,0)),U,3)
GETDT(PROMPT,DEFAULT) ;prompt and return FM date
+1 ;Input:
+2 ; PROMPT = text of prompt - DIR("A") (optional)
+3 ; DEFAULT = default date to prompt - DIR("B") (optional)
+4 ;
+5 ;Output:
+6 ; FM date/time if successfully answered, "^" if exit or timeout
+7 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+8 SET DIR(0)="DA^::EPT"
+9 SET DIR("?")="Enter the date/time the activity took place."
+10 SET DIR("A")=$SELECT($DATA(PROMPT):PROMPT_" ",1:"Actual Date/Time of Activity: ")
+11 SET DIR("B")=$SELECT($DATA(DEFAULT):DEFAULT,1:"NOW")
+12 DO ^DIR
+13 IF $DATA(DUOUT)!($DATA(DTOUT))
SET Y="^"
+14 QUIT Y
+15 ;
DCPRNT(IEN,USER) ;reprint SF-513 on DC?
+1 NEW SERV,REPR
+2 SET SERV=$PIECE(^GMR(123,IEN,0),U,5)
IF 'SERV
QUIT 0
+3 SET REPR=$PIECE($GET(^GMR(123.5,SERV,1)),U,5)
+4 IF 'REPR
QUIT 1
+5 IF REPR=2
QUIT 0
+6 IF REPR=1
IF '$$VALID^GMRCAU(SERV,IEN,USER)
QUIT 1
+7 QUIT 0
+8 ;
PREREQ(GMRCARR,GMRCSRV,GMRCDFN,UNRESOLV) ; return service pre-requisite
+1 ; pre-requisite stored in 125 nodes in file 123.5 or 123.3
+2 ; GMRCARR = array to return containing pre-requisite
+3 ; GMRCSRV = ref to file 123.5 (ien;99CON) or 123.3 (ien;99PRC)
+4 ; GMRCDFN = patient identifier if to return resolved
+5 ; UNRESOLV = 1 or 0 ; if UNRESOLV=1 GMRCARR will be returned unresolved
+6 if '+GMRCSRV
QUIT
+7 NEW GMRCFIL
+8 SET GMRCFIL=$SELECT(GMRCSRV["99PRC":123.3,1:123.5)
+9 if '$DATA(^GMR(GMRCFIL,+GMRCSRV,125))
QUIT
+10 IF '$DATA(GMRCDFN)!($GET(UNRESOLV))
Begin DoDot:1
+11 MERGE @GMRCARR=^GMR(GMRCFIL,+GMRCSRV,125)
End DoDot:1
QUIT
+12 DO BLRPLT^TIUSRVD(,,GMRCDFN,,$NAME(^GMR(GMRCFIL,+GMRCSRV,125)))
+13 IF $DATA(^TMP("TIUBOIL",$JOB))
MERGE @GMRCARR=^TMP("TIUBOIL",$JOB)
+14 KILL ^TMP("TIUBOIL",$JOB)
+15 QUIT
+16 ;
LOCKREC(GMRCDA) ;attempt to lock a consult record using order or record
+1 ; Input:
+2 ; GMRCDA = ien of consult record from file 123
+3 ;
+4 ; Output:
+5 ; 1 or 0^reason can't be locked
+6 ; 1 = successfully locked
+7 ; 0 = couldn't be locked
+8 NEW GMRCORD,GMRCMSG
+9 SET GMRCORD=$PIECE($GET(^GMR(123,GMRCDA,0)),U,3)
+10 ;an order associated
IF $GET(GMRCORD)
Begin DoDot:1
+11 SET GMRCMSG=$$LOCK1^ORX2(GMRCORD)
+12 ; GMRCMSG=1 if locked or 0 if couldn't be locked
End DoDot:1
+13 IF $LENGTH($GET(GMRCMSG))
QUIT GMRCMSG
+14 ; no order = Inter-facility Consult so lock consult record
+15 LOCK +^GMR(123,GMRCDA):5
+16 ; couldn't lock it
IF '$TEST
QUIT "0^Another user is editing this record"
+17 QUIT 1
+18 ;
UNLKREC(GMRCDA) ;unlock a consult record
+1 ; Input:
+2 ; GMRCDA = ien of consult record from file 123
+3 ;
+4 NEW GMRCORD
+5 SET GMRCORD=$PIECE($GET(^GMR(123,GMRCDA,0)),U,3)
+6 IF $GET(GMRCORD)
Begin DoDot:1
+7 DO UNLK1^ORX2(GMRCORD)
End DoDot:1
QUIT
+8 LOCK -^GMR(123,GMRCDA)
+9 QUIT
+10 ;ABV/SCR 12/14/2017 added sub-routine to generate new field #80 - UCID for *96*
NEWUCID(GMRCIEN) ;return a string that uniquely identifies this record accross VistAs
+1 ; INPUT:
+2 ; GMRCIEN ien of consult/request record from file 123
+3 ;
+4 NEW GMRCSTA,GMRCSTRN
+5 ;
+6 ;Validate the GMRCIEN exists
+7 SET GMRCSTRN=""
+8 IF $GET(^GMR(123,$GET(GMRCIEN),0))'=""
Begin DoDot:1
+9 ;RETURNS THE EXTERNAL VALUE OF THE PARAMETER
SET GMRCSTA=$$GET^XPAR("PKG","GMRC UNIQUE CONSULT SITE ID",,"E")
+10 if GMRCSTA
SET GMRCSTRN=GMRCSTA_"_"_GMRCIEN
End DoDot:1
+11 QUIT GMRCSTRN
+12 ;
