GMRCP5A ;SLC/DCM,RJS,MA - Print Consult form 513 (Gather Data - TIU Results) ;4/18/01 10:29
;;3.0;CONSULT/REQUEST TRACKING;**4,13,12,15,21,22,53**;Dec 27, 1997;Build 3
; Patch #21 added PRNTAUDT to this routine.
;
PRNT(GMRCIFN,TIUFLG,GMRCQUED,GMRCCPY,GMRCGUI,GMRCAUDT) ;
;
; Input Arguments:
;
; GMRCIFN: IEN of the Consult/Request in file 123
; TIUFLG: Called from TIU ? 1=yes 0=no
; GMRCQUED: Queued job ? 1=yes 0=no
; GMRCCPY: Chart Copy ? C=Chart Copy W=Working Copy null=Not Applicable
; GMRCGUI: Called from the GUI. (Only produce output in a formatted global.)
; GMRCAUDT: Set to 1 in GMRCUTL1 if NW or DC consult.
; ZTIO: Output device when job is tasked
;
N GMRCSIG,GMRCSDT,GMRCCSIG,GMRCSIGT,GMRCADDS
I '+$G(IOM) S IOM=80
;
I GMRCGUI D Q
. D FORMAT(80)
. D ASSMBL^GMRCP5C(GMRCGUI,80)
. F GMRCX="GMRCTIU","RES","MCAR" K ^TMP("GMRCR",$J,GMRCX)
. K ^TMP("GMRC",$J,"OUTPUT")
. Q
;
I 'TIUFLG,'GMRCQUED W @IOF I '$$CRT^GMRCP5C,$L($G(IO(0))),'(IO=IO(0)) U IO(0) W !,"PRINTING... "
;
D FORMAT(IOM),ASSMBL^GMRCP5C(IOSL,IOM)
U IO
D PRINT^GMRCP5C(IOSL,IOM)
;
I 'TIUFLG,'$$CRT^GMRCP5C U IO(0) D ^%ZISC
;
I $G(GMRCQUED),$G(ZTSK) D KILL^%ZTLOAD
;
F GMRCX="OUTPUT","SF513" K ^TMP("GMRC",$J,GMRCX)
F GMRCX="GMRCTIU","RES","MCAR" K ^TMP("GMRCR",$J,GMRCX)
; If print device (ZTIO) do PRNTAUDT unless there is no GMRCAUDT
; GMRCAUDT=1 means print for NW or DC consult
I $D(ZTIO),$D(GMRCAUDT) D PRNTAUDT(GMRCIFN,ZTIO,GMRCAUDT)
Q
;
PRNTAUDT(GMRCIFN,ZTIO,GMRCAUDT) ; Update the last activity field in 123 and
; Processing Activity multiple
; Update the activity log to reflect "Printed To:" and the printer
; GMRCAUDT=1 indicates the consult is NW or Discontinued
; and it should update the audit trail.
I $G(GMRCAUDT)'=1 K GMRCAUDT Q
N GMRCOM,GMRCORNP,GMRCFF,GMRCPA,GMRCAD,GMRCA,DA,DIE
S GMRCA=22
S GMRCO=GMRCIFN,GMRCDEV=ZTIO
S DIE="^GMR(123,",DA=+GMRCO,DR="9////^S X=GMRCA"
L +^GMR(123,GMRCO):5
D ^DIE
L -^GMR(123,GMRCO)
;Update activity other than HL7 original msg received
D AUDIT^GMRCP
KILL GMRCO,GMRCA,GMRCDEV
Q
;
FORMAT(PAGEWID) ;
;
N %I,CMT,COUNT,D0,DFN,DIC,DIQ2,DR,GLOBAL,GMRC400,GMRCADD,GMRCADDT,GMRCAGE,GMRCCSDT
N GMRCCTIT,GMRCDFN,GMRCDOB,GMRCDVL,GMRCELIG,GMRCEQL,GMRCERR,GMRCFAC,GMRCFP
N GMRCFTR,GMRCIPH,GMRCINO,GMRCIRL,GMRCLAST,GMRCMODE,GMRCND,GMRCNDX,GMRCNT,GMRCPG,GMRCPGR,GMRCPNM,GMRCPRNM
N GMRCPTR,GMRCQSTR,GMRCQSTT,GMRCR0,GMRCR1,GMRCR2,GMRCRB,GMRCRD,GMRCRPT,GMRCSG,GMRCSGAD,GMRCSIGM
N GMRCSN,GMRCSR,GMRCSVC,GMRCTO,GMRCUL,GMRCWARD,GMRCWLI,GMRCX,LN,MCFILE,MCPROC
N ND,ND1,ND2,NDS,ORACTION,SEX,TAB,X,Y
;
S GMRCFTR=13,GMRCFP=0,GMRCPG=0
S GMRCRD=$G(^GMR(123,GMRCIFN,0)),(DFN,GMRCDFN)=$P(GMRCRD,U,2)
Q:'(DFN)
D ELIG^VADPT S GMRCELIG=$P(VAEL(6),U,2) K VAEL
S GMRCDVL="",$P(GMRCDVL,"-",PAGEWID+1)=""
S GMRCEQL="",$P(GMRCEQL,"=",PAGEWID+1)=""
S GMRCUL="",$P(GMRCUL,"_",40)=""
S DFN=GMRCDFN D DEM^GMRCU
;
S GMRCFAC=+$P(GMRCRD,U,21)
I 'GMRCFAC S GMRCFAC=+$G(DUZ(2))
I 'GMRCFAC S GMRCFAC=+$$SITE^VASITE()
I +GMRCFAC S GMRCFAC=$$GET1^DIQ(4,+GMRCFAC,.01)
E S GMRCFAC="" Q
;
; get inter-facility consult info
I $P(GMRCRD,U,23) D
.S GMRCINO=$P(GMRCRD,U,22)
.S GMRCRD(12)=$G(^GMR(123,GMRCIFN,12))
.S GMRCRD(13)=$G(^GMR(123,GMRCIFN,13))
.S GMRCIRL=$S($P(GMRCRD(12),U,5)="P":"Requesting facility",$P(GMRCRD(12),U,5)="F":"Consulting facility",1:"")
;Commented out following line to allow TIU doc to print based on ASU
;rules.
;I $P(GMRCRD,U,12)=2!(TIUFLG) D
D PRINT^GMRCTIUP(GMRCIFN,0,0) ;Removed dot structure
;
K GMRCSG I $D(^TMP("GMRCR",$J,"RES")) D
.;
.S GMRCR0=0 F Q:$D(GMRCSG) S GMRCR0=$O(^TMP("GMRCR",$J,"RES",GMRCR0)) Q:'GMRCR0 D
..F GMRCV="GMRCSDT","GMRCSIG","GMRCSIGM","GMRCSIGT" S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT",GMRCV))
..Q:'$L($G(GMRCSIG))
..F GMRCV="GMRCSDT","GMRCSIG","GMRCSIGM","GMRCSIGT" S GMRCSG(GMRCV)=@GMRCV
;
D INIT^GMRCP5B(.GMRCSG) ; Build Header, Footer, Request, and Primary Diagnosis Segments
;
I $L($G(GMRCCPY)) D
.D BLD("RES",1,1,0,$$CENTER($S(GMRCCPY="C":"C H A R T C O P Y",1:"W O R K I N G C O P Y")))
I ($P(GMRCRD,U,19)="Y") D
.D BLD("RES",1,1,0,$$CENTER("******* Significant Findings *******"))
I ($P(GMRCRD,U,19)="N") D
.D BLD("RES",1,1,0,$$CENTER("******* No Significant Findings *******"))
I ($P(GMRCRD,U,19)="U") D
.D BLD("RES",1,1,0,$$CENTER("******* Unknown Significant Findings *******"))
;
I $P(GMRCRD,U,12)=1 D
. D BLD("RES",1,2,0,$$CENTER("**** REQUEST CANCELLED REQUEST CANCELLED ****"))
I '$D(^TMP("GMRCR",$J,"RES")),'$D(^("MCAR")) D
.I $L($G(GMRCRPT)) D BLD("RES",1,2,0,$$CENTER(" No Consultation Results for "_GMRCRPT_" available."))
.I '$L($G(GMRCRPT)) D BLD("RES",1,2,0,$$CENTER(" No Consultation Results available."))
;
I $D(^TMP("GMRCR",$J,"RES")) D
.;
.S (GMRCNT,GMRCR0)=0 F S GMRCR0=$O(^TMP("GMRCR",$J,"RES",GMRCR0)) Q:'GMRCR0 D
..N GMRCCSDT,GMRCCSGM,GMRCCSIG,GMRCCTIT,GMRCRPT,GMRCSDT
..N GMRCSIG,GMRCSIGM,GMRCSIGT,GMRCV,GMRCENT,GMRCVIS,GMRCVLOC,GMRCNODT
..;
..F GMRCV="GMRCCSDT","GMRCCSGM","GMRCCSIG","GMRCCTIT","GMRCRPT","GMRCSDT","GMRCSIG","GMRCSIGM","GMRCSIGT","GMRCVIS","GMRCENT","GMRCVLOC","GMRCNODT" D
...S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT",GMRCV))
..;
..S GMRCNDX=$O(^TMP("GMRC",$J,"OUTPUT","RES"," "),-1)+1
..I $L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Consultation Results "_$S(GMRCR0=.5:"",1:"#"_GMRCR0_" ")_"for "_GMRCRPT_" continued.")
..I '$L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Consultation Results "_$S(GMRCR0=.5:"",1:"#"_GMRCR0_" ")_"continued.")
..D SUB("H","RES",GMRCNDX," ")
..I $L($G(GMRCSIG)) D
...D SUB("F","RES",GMRCNDX," ")
...I (GMRCSIGM="electronic") S GMRCX=" Results Signature: "_GMRCSIG_" /es/ "_$$EXDT($G(GMRCSDT))
...I '(GMRCSIGM="electronic") S GMRCX=" Results Signature: "_GMRCSIG_" /chart/ " S:$L($G(GMRCSDT)) GMRCX=GMRCX_$$EXDT(GMRCSDT)
...D SUB("F","RES",GMRCNDX,GMRCX)
...D:$L($G(GMRCSIGT)) SUB("F","RES",GMRCNDX," "_GMRCSIGT)
..I $L($G(GMRCCSIG)) D
...D SUB("F","RES",GMRCNDX," ")
...I (GMRCCSGM="electronic") S GMRCX=" Results CoSignature: "_GMRCCSIG_" /es/ "_$$EXDT($G(GMRCCSDT))
...I '(GMRCCSGM="electronic") S GMRCX=" Results CoSignature: "_GMRCCSIG_" /chart/ " S:$L($G(GMRCCSDT)) GMRCX=GMRCX_$$EXDT(GMRCCSDT)
...D SUB("F","RES",GMRCNDX,GMRCX)
...D:$L($G(GMRCCTIT)) SUB("F","RES",GMRCNDX," "_GMRCCTIT)
..;extra signers
.. I $D(^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT","GMRCXTRA")) D
... D SUB("F","RES",GMRCNDX," ")
... D SUB("F","RES",GMRCNDX," Receipt acknowledged by: ")
... N XTRA S XTRA=0 F S XTRA=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT","GMRCXTRA",XTRA)) Q:'XTRA D
.... D SUB("F","RES",GMRCNDX,^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT","GMRCXTRA",XTRA,0))
.... D SUB("F","RES",GMRCNDX,^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT","GMRCXTRA",XTRA,1))
..;
..D BLD("RES",GMRCNDX,1,0," ")
..I $L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("CONSULTATION NOTE "_$S(GMRCR0=.5:"",1:"#"_GMRCR0_" ")_"FOR "_GMRCRPT))
..I '$L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("CONSULTATION NOTE "_$S(GMRCR0=.5:"",1:"#"_GMRCR0)))
..D BLD("RES",GMRCNDX,1,0," ")
..I $L($G(GMRCENT)) D
...S GMRCX=" Entry Date: "_$$EXDT($G(GMRCENT))
...D BLD("RES",GMRCNDX,1,0,GMRCX)
..I $L($G(GMRCNODT)) D
...Q:$$EXDT($G(GMRCNODT))=$$EXDT($G(GMRCENT))
...S GMRCX="Date/Time of result: "_$$EXDT($G(GMRCNODT))
...D BLD("RES",GMRCNDX,1,0,GMRCX)
..I $L($G(GMRCVIS)) D
...S GMRCX=" Visit: "_$$EXDT($G(GMRCVIS))
...I $L($G(GMRCVLOC)) S GMRCX=GMRCX_" "_GMRCVLOC
...D BLD("RES",GMRCNDX,1,0,GMRCX)
..I $L($G(GMRCVLOC)) S GMRCX=GMRCVLOC
..D BLD("RES",GMRCNDX,1,0," ")
..I $D(^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT",0,0)) D I 1
...D BLD("RES",GMRCNDX,1,0,^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT",0,0))
..E I '$O(^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT","")) D
...D BLD("RES",1,1,0,$$CENTER("CONSULTATION NOTE TEXT NOT AVAILABLE"))
..S GMRCR1=0 F S GMRCR1=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT",GMRCR1)) Q:'GMRCR1 D
...D BLD("RES",GMRCNDX,1,0,^TMP("GMRCR",$J,"RES",GMRCR0,"TEXT",GMRCR1,0))
..;
..; GET ADDENDUMS TO THIS NOTE
..;
..I +$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",0)) D ADDEND^GMRCP5D(GMRCIFN,GMRCR0,GMRCNDX,GMRCRD,PAGEWID)
;
D FORMAT^GMRCP5D(GMRCIFN,GMRCRD,PAGEWID) ; GET SERVICE REPORTS AND COMMENTS
;
Q
;
EXDT(X) ;EXTERNAL DATE FORMAT
;
N DATE,TIME,HR,MN,PD,Y,%DT
Q:'$L(X) ""
I '(X?7N.1".".6N) S %DT="PTS" D ^%DT S X=Y
Q $$FMTE^XLFDT(X,"5PMZ")
;
CENTER(X) ;
;
N TEXT,COL
S COL=35-($L(X)\2) Q:(COL<1) X
S $E(TEXT,COL)=X
Q TEXT
;
BLD(SUB,NDX,LINE,TAB,TEXT,RUNTIME) ;
;
Q:'$L($G(SUB))
N LINECNT
;
F LINECNT=1:1:+LINE S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX)+1,0)=""
;
S $E(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),0),TAB+1)=TEXT
I $L($G(RUNTIME)) S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),1)=RUNTIME
;
S GMRCLAST=SUB
Q
;
SUB(ZONE,SUB,NDX,TEXT) ;
;
N NEXT
S NEXT=$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE," "),-1)+1
S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE,NEXT,0)=TEXT
Q
;
LASTLN(SUB,NDX) ;
Q +$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX," "),-1)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCP5A 9247 printed Sep 23, 2025@19:22:32 Page 2
GMRCP5A ;SLC/DCM,RJS,MA - Print Consult form 513 (Gather Data - TIU Results) ;4/18/01 10:29
+1 ;;3.0;CONSULT/REQUEST TRACKING;**4,13,12,15,21,22,53**;Dec 27, 1997;Build 3
+2 ; Patch #21 added PRNTAUDT to this routine.
+3 ;
PRNT(GMRCIFN,TIUFLG,GMRCQUED,GMRCCPY,GMRCGUI,GMRCAUDT) ;
+1 ;
+2 ; Input Arguments:
+3 ;
+4 ; GMRCIFN: IEN of the Consult/Request in file 123
+5 ; TIUFLG: Called from TIU ? 1=yes 0=no
+6 ; GMRCQUED: Queued job ? 1=yes 0=no
+7 ; GMRCCPY: Chart Copy ? C=Chart Copy W=Working Copy null=Not Applicable
+8 ; GMRCGUI: Called from the GUI. (Only produce output in a formatted global.)
+9 ; GMRCAUDT: Set to 1 in GMRCUTL1 if NW or DC consult.
+10 ; ZTIO: Output device when job is tasked
+11 ;
+12 NEW GMRCSIG,GMRCSDT,GMRCCSIG,GMRCSIGT,GMRCADDS
+13 IF '+$GET(IOM)
SET IOM=80
+14 ;
+15 IF GMRCGUI
Begin DoDot:1
+16 DO FORMAT(80)
+17 DO ASSMBL^GMRCP5C(GMRCGUI,80)
+18 FOR GMRCX="GMRCTIU","RES","MCAR"
KILL ^TMP("GMRCR",$JOB,GMRCX)
+19 KILL ^TMP("GMRC",$JOB,"OUTPUT")
+20 QUIT
End DoDot:1
QUIT
+21 ;
+22 IF 'TIUFLG
IF 'GMRCQUED
WRITE @IOF
IF '$$CRT^GMRCP5C
IF $LENGTH($GET(IO(0)))
IF '(IO=IO(0))
USE IO(0)
WRITE !,"PRINTING... "
+23 ;
+24 DO FORMAT(IOM)
DO ASSMBL^GMRCP5C(IOSL,IOM)
+25 USE IO
+26 DO PRINT^GMRCP5C(IOSL,IOM)
+27 ;
+28 IF 'TIUFLG
IF '$$CRT^GMRCP5C
USE IO(0)
DO ^%ZISC
+29 ;
+30 IF $GET(GMRCQUED)
IF $GET(ZTSK)
DO KILL^%ZTLOAD
+31 ;
+32 FOR GMRCX="OUTPUT","SF513"
KILL ^TMP("GMRC",$JOB,GMRCX)
+33 FOR GMRCX="GMRCTIU","RES","MCAR"
KILL ^TMP("GMRCR",$JOB,GMRCX)
+34 ; If print device (ZTIO) do PRNTAUDT unless there is no GMRCAUDT
+35 ; GMRCAUDT=1 means print for NW or DC consult
+36 IF $DATA(ZTIO)
IF $DATA(GMRCAUDT)
DO PRNTAUDT(GMRCIFN,ZTIO,GMRCAUDT)
+37 QUIT
+38 ;
PRNTAUDT(GMRCIFN,ZTIO,GMRCAUDT) ; Update the last activity field in 123 and
+1 ; Processing Activity multiple
+2 ; Update the activity log to reflect "Printed To:" and the printer
+3 ; GMRCAUDT=1 indicates the consult is NW or Discontinued
+4 ; and it should update the audit trail.
+5 IF $GET(GMRCAUDT)'=1
KILL GMRCAUDT
QUIT
+6 NEW GMRCOM,GMRCORNP,GMRCFF,GMRCPA,GMRCAD,GMRCA,DA,DIE
+7 SET GMRCA=22
+8 SET GMRCO=GMRCIFN
SET GMRCDEV=ZTIO
+9 SET DIE="^GMR(123,"
SET DA=+GMRCO
SET DR="9////^S X=GMRCA"
+10 LOCK +^GMR(123,GMRCO):5
+11 DO ^DIE
+12 LOCK -^GMR(123,GMRCO)
+13 ;Update activity other than HL7 original msg received
+14 DO AUDIT^GMRCP
+15 KILL GMRCO,GMRCA,GMRCDEV
+16 QUIT
+17 ;
FORMAT(PAGEWID) ;
+1 ;
+2 NEW %I,CMT,COUNT,D0,DFN,DIC,DIQ2,DR,GLOBAL,GMRC400,GMRCADD,GMRCADDT,GMRCAGE,GMRCCSDT
+3 NEW GMRCCTIT,GMRCDFN,GMRCDOB,GMRCDVL,GMRCELIG,GMRCEQL,GMRCERR,GMRCFAC,GMRCFP
+4 NEW GMRCFTR,GMRCIPH,GMRCINO,GMRCIRL,GMRCLAST,GMRCMODE,GMRCND,GMRCNDX,GMRCNT,GMRCPG,GMRCPGR,GMRCPNM,GMRCPRNM
+5 NEW GMRCPTR,GMRCQSTR,GMRCQSTT,GMRCR0,GMRCR1,GMRCR2,GMRCRB,GMRCRD,GMRCRPT,GMRCSG,GMRCSGAD,GMRCSIGM
+6 NEW GMRCSN,GMRCSR,GMRCSVC,GMRCTO,GMRCUL,GMRCWARD,GMRCWLI,GMRCX,LN,MCFILE,MCPROC
+7 NEW ND,ND1,ND2,NDS,ORACTION,SEX,TAB,X,Y
+8 ;
+9 SET GMRCFTR=13
SET GMRCFP=0
SET GMRCPG=0
+10 SET GMRCRD=$GET(^GMR(123,GMRCIFN,0))
SET (DFN,GMRCDFN)=$PIECE(GMRCRD,U,2)
+11 if '(DFN)
QUIT
+12 DO ELIG^VADPT
SET GMRCELIG=$PIECE(VAEL(6),U,2)
KILL VAEL
+13 SET GMRCDVL=""
SET $PIECE(GMRCDVL,"-",PAGEWID+1)=""
+14 SET GMRCEQL=""
SET $PIECE(GMRCEQL,"=",PAGEWID+1)=""
+15 SET GMRCUL=""
SET $PIECE(GMRCUL,"_",40)=""
+16 SET DFN=GMRCDFN
DO DEM^GMRCU
+17 ;
+18 SET GMRCFAC=+$PIECE(GMRCRD,U,21)
+19 IF 'GMRCFAC
SET GMRCFAC=+$GET(DUZ(2))
+20 IF 'GMRCFAC
SET GMRCFAC=+$$SITE^VASITE()
+21 IF +GMRCFAC
SET GMRCFAC=$$GET1^DIQ(4,+GMRCFAC,.01)
+22 IF '$TEST
SET GMRCFAC=""
QUIT
+23 ;
+24 ; get inter-facility consult info
+25 IF $PIECE(GMRCRD,U,23)
Begin DoDot:1
+26 SET GMRCINO=$PIECE(GMRCRD,U,22)
+27 SET GMRCRD(12)=$GET(^GMR(123,GMRCIFN,12))
+28 SET GMRCRD(13)=$GET(^GMR(123,GMRCIFN,13))
+29 SET GMRCIRL=$SELECT($PIECE(GMRCRD(12),U,5)="P":"Requesting facility",$PIECE(GMRCRD(12),U,5)="F":"Consulting facility",1:"")
End DoDot:1
+30 ;Commented out following line to allow TIU doc to print based on ASU
+31 ;rules.
+32 ;I $P(GMRCRD,U,12)=2!(TIUFLG) D
+33 ;Removed dot structure
DO PRINT^GMRCTIUP(GMRCIFN,0,0)
+34 ;
+35 KILL GMRCSG
IF $DATA(^TMP("GMRCR",$JOB,"RES"))
Begin DoDot:1
+36 ;
+37 SET GMRCR0=0
FOR
if $DATA(GMRCSG)
QUIT
SET GMRCR0=$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0))
if 'GMRCR0
QUIT
Begin DoDot:2
+38 FOR GMRCV="GMRCSDT","GMRCSIG","GMRCSIGM","GMRCSIGT"
SET @GMRCV=$GET(^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT",GMRCV))
+39 if '$LENGTH($GET(GMRCSIG))
QUIT
+40 FOR GMRCV="GMRCSDT","GMRCSIG","GMRCSIGM","GMRCSIGT"
SET GMRCSG(GMRCV)=@GMRCV
End DoDot:2
End DoDot:1
+41 ;
+42 ; Build Header, Footer, Request, and Primary Diagnosis Segments
DO INIT^GMRCP5B(.GMRCSG)
+43 ;
+44 IF $LENGTH($GET(GMRCCPY))
Begin DoDot:1
+45 DO BLD("RES",1,1,0,$$CENTER($SELECT(GMRCCPY="C":"C H A R T C O P Y",1:"W O R K I N G C O P Y")))
End DoDot:1
+46 IF ($PIECE(GMRCRD,U,19)="Y")
Begin DoDot:1
+47 DO BLD("RES",1,1,0,$$CENTER("******* Significant Findings *******"))
End DoDot:1
+48 IF ($PIECE(GMRCRD,U,19)="N")
Begin DoDot:1
+49 DO BLD("RES",1,1,0,$$CENTER("******* No Significant Findings *******"))
End DoDot:1
+50 IF ($PIECE(GMRCRD,U,19)="U")
Begin DoDot:1
+51 DO BLD("RES",1,1,0,$$CENTER("******* Unknown Significant Findings *******"))
End DoDot:1
+52 ;
+53 IF $PIECE(GMRCRD,U,12)=1
Begin DoDot:1
+54 DO BLD("RES",1,2,0,$$CENTER("**** REQUEST CANCELLED REQUEST CANCELLED ****"))
End DoDot:1
+55 IF '$DATA(^TMP("GMRCR",$JOB,"RES"))
IF '$DATA(^("MCAR"))
Begin DoDot:1
+56 IF $LENGTH($GET(GMRCRPT))
DO BLD("RES",1,2,0,$$CENTER(" No Consultation Results for "_GMRCRPT_" available."))
+57 IF '$LENGTH($GET(GMRCRPT))
DO BLD("RES",1,2,0,$$CENTER(" No Consultation Results available."))
End DoDot:1
+58 ;
+59 IF $DATA(^TMP("GMRCR",$JOB,"RES"))
Begin DoDot:1
+60 ;
+61 SET (GMRCNT,GMRCR0)=0
FOR
SET GMRCR0=$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0))
if 'GMRCR0
QUIT
Begin DoDot:2
+62 NEW GMRCCSDT,GMRCCSGM,GMRCCSIG,GMRCCTIT,GMRCRPT,GMRCSDT
+63 NEW GMRCSIG,GMRCSIGM,GMRCSIGT,GMRCV,GMRCENT,GMRCVIS,GMRCVLOC,GMRCNODT
+64 ;
+65 FOR GMRCV="GMRCCSDT","GMRCCSGM","GMRCCSIG","GMRCCTIT","GMRCRPT","GMRCSDT","GMRCSIG","GMRCSIGM","GMRCSIGT","GMRCVIS","GMRCENT","GMRCVLOC","GMRCNODT"
Begin DoDot:3
+66 SET @GMRCV=$GET(^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT",GMRCV))
End DoDot:3
+67 ;
+68 SET GMRCNDX=$ORDER(^TMP("GMRC",$JOB,"OUTPUT","RES"," "),-1)+1
+69 IF $LENGTH($GET(GMRCRPT))
DO SUB("H","RES",GMRCNDX,"Consultation Results "_$SELECT(GMRCR0=.5:"",1:"#"_GMRCR0_" ")_"for "_GMRCRPT_" continued.")
+70 IF '$LENGTH($GET(GMRCRPT))
DO SUB("H","RES",GMRCNDX,"Consultation Results "_$SELECT(GMRCR0=.5:"",1:"#"_GMRCR0_" ")_"continued.")
+71 DO SUB("H","RES",GMRCNDX," ")
+72 IF $LENGTH($GET(GMRCSIG))
Begin DoDot:3
+73 DO SUB("F","RES",GMRCNDX," ")
+74 IF (GMRCSIGM="electronic")
SET GMRCX=" Results Signature: "_GMRCSIG_" /es/ "_$$EXDT($GET(GMRCSDT))
+75 IF '(GMRCSIGM="electronic")
SET GMRCX=" Results Signature: "_GMRCSIG_" /chart/ "
if $LENGTH($GET(GMRCSDT))
SET GMRCX=GMRCX_$$EXDT(GMRCSDT)
+76 DO SUB("F","RES",GMRCNDX,GMRCX)
+77 if $LENGTH($GET(GMRCSIGT))
DO SUB("F","RES",GMRCNDX," "_GMRCSIGT)
End DoDot:3
+78 IF $LENGTH($GET(GMRCCSIG))
Begin DoDot:3
+79 DO SUB("F","RES",GMRCNDX," ")
+80 IF (GMRCCSGM="electronic")
SET GMRCX=" Results CoSignature: "_GMRCCSIG_" /es/ "_$$EXDT($GET(GMRCCSDT))
+81 IF '(GMRCCSGM="electronic")
SET GMRCX=" Results CoSignature: "_GMRCCSIG_" /chart/ "
if $LENGTH($GET(GMRCCSDT))
SET GMRCX=GMRCX_$$EXDT(GMRCCSDT)
+82 DO SUB("F","RES",GMRCNDX,GMRCX)
+83 if $LENGTH($GET(GMRCCTIT))
DO SUB("F","RES",GMRCNDX," "_GMRCCTIT)
End DoDot:3
+84 ;extra signers
+85 IF $DATA(^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT","GMRCXTRA"))
Begin DoDot:3
+86 DO SUB("F","RES",GMRCNDX," ")
+87 DO SUB("F","RES",GMRCNDX," Receipt acknowledged by: ")
+88 NEW XTRA
SET XTRA=0
FOR
SET XTRA=$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT","GMRCXTRA",XTRA))
if 'XTRA
QUIT
Begin DoDot:4
+89 DO SUB("F","RES",GMRCNDX,^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT","GMRCXTRA",XTRA,0))
+90 DO SUB("F","RES",GMRCNDX,^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT","GMRCXTRA",XTRA,1))
End DoDot:4
End DoDot:3
+91 ;
+92 DO BLD("RES",GMRCNDX,1,0," ")
+93 IF $LENGTH($GET(GMRCRPT))
DO BLD("RES",GMRCNDX,1,0,$$CENTER("CONSULTATION NOTE "_$SELECT(GMRCR0=.5:"",1:"#"_GMRCR0_" ")_"FOR "_GMRCRPT))
+94 IF '$LENGTH($GET(GMRCRPT))
DO BLD("RES",GMRCNDX,1,0,$$CENTER("CONSULTATION NOTE "_$SELECT(GMRCR0=.5:"",1:"#"_GMRCR0)))
+95 DO BLD("RES",GMRCNDX,1,0," ")
+96 IF $LENGTH($GET(GMRCENT))
Begin DoDot:3
+97 SET GMRCX=" Entry Date: "_$$EXDT($GET(GMRCENT))
+98 DO BLD("RES",GMRCNDX,1,0,GMRCX)
End DoDot:3
+99 IF $LENGTH($GET(GMRCNODT))
Begin DoDot:3
+100 if $$EXDT($GET(GMRCNODT))=$$EXDT($GET(GMRCENT))
QUIT
+101 SET GMRCX="Date/Time of result: "_$$EXDT($GET(GMRCNODT))
+102 DO BLD("RES",GMRCNDX,1,0,GMRCX)
End DoDot:3
+103 IF $LENGTH($GET(GMRCVIS))
Begin DoDot:3
+104 SET GMRCX=" Visit: "_$$EXDT($GET(GMRCVIS))
+105 IF $LENGTH($GET(GMRCVLOC))
SET GMRCX=GMRCX_" "_GMRCVLOC
+106 DO BLD("RES",GMRCNDX,1,0,GMRCX)
End DoDot:3
+107 IF $LENGTH($GET(GMRCVLOC))
SET GMRCX=GMRCVLOC
+108 DO BLD("RES",GMRCNDX,1,0," ")
+109 IF $DATA(^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT",0,0))
Begin DoDot:3
+110 DO BLD("RES",GMRCNDX,1,0,^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT",0,0))
End DoDot:3
IF 1
+111 IF '$TEST
IF '$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT",""))
Begin DoDot:3
+112 DO BLD("RES",1,1,0,$$CENTER("CONSULTATION NOTE TEXT NOT AVAILABLE"))
End DoDot:3
+113 SET GMRCR1=0
FOR
SET GMRCR1=$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT",GMRCR1))
if 'GMRCR1
QUIT
Begin DoDot:3
+114 DO BLD("RES",GMRCNDX,1,0,^TMP("GMRCR",$JOB,"RES",GMRCR0,"TEXT",GMRCR1,0))
End DoDot:3
+115 ;
+116 ; GET ADDENDUMS TO THIS NOTE
+117 ;
+118 IF +$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0,"ADD",0))
DO ADDEND^GMRCP5D(GMRCIFN,GMRCR0,GMRCNDX,GMRCRD,PAGEWID)
End DoDot:2
End DoDot:1
+119 ;
+120 ; GET SERVICE REPORTS AND COMMENTS
DO FORMAT^GMRCP5D(GMRCIFN,GMRCRD,PAGEWID)
+121 ;
+122 QUIT
+123 ;
EXDT(X) ;EXTERNAL DATE FORMAT
+1 ;
+2 NEW DATE,TIME,HR,MN,PD,Y,%DT
+3 if '$LENGTH(X)
QUIT ""
+4 IF '(X?7N.1".".6N)
SET %DT="PTS"
DO ^%DT
SET X=Y
+5 QUIT $$FMTE^XLFDT(X,"5PMZ")
+6 ;
CENTER(X) ;
+1 ;
+2 NEW TEXT,COL
+3 SET COL=35-($LENGTH(X)\2)
if (COL<1)
QUIT X
+4 SET $EXTRACT(TEXT,COL)=X
+5 QUIT TEXT
+6 ;
BLD(SUB,NDX,LINE,TAB,TEXT,RUNTIME) ;
+1 ;
+2 if '$LENGTH($GET(SUB))
QUIT
+3 NEW LINECNT
+4 ;
+5 FOR LINECNT=1:1:+LINE
SET ^TMP("GMRC",$JOB,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX)+1,0)=""
+6 ;
+7 SET $EXTRACT(^TMP("GMRC",$JOB,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),0),TAB+1)=TEXT
+8 IF $LENGTH($GET(RUNTIME))
SET ^TMP("GMRC",$JOB,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),1)=RUNTIME
+9 ;
+10 SET GMRCLAST=SUB
+11 QUIT
+12 ;
SUB(ZONE,SUB,NDX,TEXT) ;
+1 ;
+2 NEW NEXT
+3 SET NEXT=$ORDER(^TMP("GMRC",$JOB,"OUTPUT",SUB,NDX,ZONE," "),-1)+1
+4 SET ^TMP("GMRC",$JOB,"OUTPUT",SUB,NDX,ZONE,NEXT,0)=TEXT
+5 QUIT
+6 ;
LASTLN(SUB,NDX) ;
+1 QUIT +$ORDER(^TMP("GMRC",$JOB,"OUTPUT",SUB,NDX," "),-1)
+2 ;
