GMRCP5D ;SLC/DCM,RJS,JFR,WAT,DEH - Print Consult form 513 (Gather Data - Addendums, Headers, Service reports and Comments) ;01/20/17 15:19
;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,22,29,35,38,61,65,66,82,89**;Dec 27, 1997;Build 62
;Waiver #301965 submitted 2014.02.02,pending as of 2015.05.05/JDT
; MILW/RH/JDT 9/09 HDR+26,+27 concantenated age to DOB
; MILW/JDT HDR+41 add cell phone to header
; WLE added Cell phone and age to SF513
;This routine invokes the following ICR(s):
;2056 $$GET1^DIQ, 2541 $$KSP^XUPARAM, 10103 $$FMTE^XLFDT, 10104 $$UP^XLFSTR, 10061 VADPT API
;10040 ^SC(, 4156 $$CVEDT^DGCV
;
FORMAT(GMRCIFN,GMRCRD,PAGEWID) ;
;
I $L($P(GMRCRD,U,15)) D
.I $O(^TMP("GMRCR",$J,"MCAR",0)) D
..N GMRCSVC
..S GMRCSVC=$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1)
..S:$L(GMRCSVC) GMRCSVC=GMRCSVC_" "
..;
..; Medicine Results?
..S GMRCR0=0 F S GMRCR0=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0)) Q:'GMRCR0 D
...D SUB("H","SREP",GMRCR0,$$CENTER(GMRCSVC_"Service Report #"_GMRCR0_" continued."))
...D SUB("H","SREP",GMRCR0," ")
...D BLD("SREP",GMRCR0,1,0,$$CENTER("Medicine Package Report"))
...D BLD("SREP",GMRCR0,1,0,"")
...N LN
...S LN=0 F S LN=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN)) Q:'LN D
....D BLD("SREP",GMRCR0,1,0,$G(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN,0)))
;
; Build Processing Activities
S GMRCR0=0 F S GMRCR0=$O(^GMR(123,GMRCIFN,40,GMRCR0)) Q:'GMRCR0 D
.N GMRCR1,GMRC400,CMT,USER,GMRCDT,RPRV,GMRC402,GMRCISIT
.S GMRCR1=+$O(^GMR(123,GMRCIFN,40,GMRCR0,0)) Q:GMRCR1'=1
.S GMRC400=$G(^GMR(123,GMRCIFN,40,GMRCR0,0))
.S GMRC402=$G(^GMR(123,GMRCIFN,40,GMRCR0,2))
.S CMT=$$PRCMT^GMRCP5B(+$P(GMRC400,U,2)) Q:'$L(CMT)
.S GMRCDT=$P(GMRC400,U,3) S:'GMRCDT GMRCDT=$P(GMRC400,U,1)
.S GMRCDT=$$EXDT(GMRCDT)_" "_$P(GMRC402,U,3)
.;Following lines modified in patch *38
.;I $P(^GMR(123,GMRCIFN,0),U,23) D ;commented out
.;.S GMRCISIT=$$GET1^DIQ(4,$P(^GMR(123,GMRCIFN,0),U,23),.01) ;commented out
.;.S GMRCISIT="Entered at: "_GMRCISIT ;commented out
.I $L(GMRC402) D ;ADDED
..S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.07) ;ADDED
.I '$D(GMRCISIT) D ;ADDED
..S GMRCISIT=$$KSP^XUPARAM("INST") ;ADDED
..I GMRCISIT'="" S GMRCISIT=$$GET1^DIQ(4,GMRCISIT,.01) ;ADDED
..I GMRCISIT="" S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.05) ;ADDED
.S GMRCISIT="Entered at: "_GMRCISIT ;ADDED
.;End of modifications for patch *38
.S RPRV=$$GET1^DIQ(200,+$P(GMRC400,U,4),.01)
.I '$L(RPRV) S RPRV=$P(GMRC402,U,2)
.S:($L(RPRV)) RPRV="Responsible Person: "_RPRV
.S USER=$$GET1^DIQ(200,+$P(GMRC400,U,5),.01)
.I '$L(USER) S USER=$P(GMRC402,U)
.S USER="Entered by: "_USER_" - "_GMRCDT
.D SUB("H","COM",GMRCR0,CMT_" Comment ("_USER_") continued.")
.D SUB("H","COM",GMRCR0," ")
.D BLD("COM",GMRCR0,1,0,"")
.D BLD("COM",GMRCR0,1,0,$$CENTER("("_CMT_" Comment)"))
.I $P(GMRC400,U,2)=17!($P(GMRC400,U,2)=25) D
.. N FWDLN,FWDRS
.. S FWDLN="Forwarded from: "
.. S FWDRS=$P($G(^GMR(123,GMRCIFN,40,GMRCR0,3)),U)
.. I $L(FWDRS) S FWDLN=FWDLN_FWDRS
.. I '$L(FWDRS) S FWDLN=FWDLN_$$GET1^DIQ(123.5,+$P(GMRC400,U,6),.01)
.. D BLD("COM",GMRCR0,1,5,FWDLN)
.D BLD("COM",GMRCR0,1,5,USER)
.D:($L(RPRV)) BLD("COM",GMRCR0,1,5,RPRV)
.D:($L($G(GMRCISIT))) BLD("COM",GMRCR0,1,5,GMRCISIT)
.;
.N GMRCR2 S GMRCR2=0
.F S GMRCR2=$O(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2)) Q:'GMRCR2 D
..D BLD("COM",GMRCR0,1,0,$G(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2,0)))
;
Q
;
ADDEND(GMRCIFN,GMRCR0,GMRCNDX,GMRCRD,PAGEWID) ;
;
N GMRCADD,GMRCNDX,GMRCR1,GMRCV,TEXT,GMRCX
;
S GMRCADD=0 F S GMRCADD=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD)) Q:'GMRCADD D
.N GMRCSGNM,GMRCNMDT,GMRCTIT,GMRCMODE,GMRCCSDT,GMRCCTIT,GMRCCSGM
.;
.F GMRCV="GMRCSGNM","GMRCNMDT","GMRCTIT","GMRCMODE" D
..S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV))
.;
. F GMRCV="GMRCCSDT","GMRCCTIT","GMRCCSGM","GMRCCSIG" D
.. S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV))
.S GMRCNDX=$O(^TMP("GMRC",$J,"OUTPUT","RES"," "),-1)+1
.I $L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" for "_GMRCRPT_" continued.")
.I '$L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" continued.")
.D SUB("H","RES",GMRCNDX," ")
.I $L($G(GMRCSGNM)) D
..D SUB("F","RES",GMRCNDX," ")
..I (GMRCMODE="electronic") S GMRCX=" Addendum Signature: "_GMRCSGNM_" /es/ "_$$EXDT($G(GMRCNMDT))
..I '(GMRCMODE="electronic") S GMRCX=" Addendum Author: "_GMRCSGNM S:$L($G(GMRCNMDT)) GMRCX=GMRCX_" Last edited: "_$$EXDT(GMRCNMDT)
..D SUB("F","RES",GMRCNDX,GMRCX)
..D:$L($G(GMRCTIT)) SUB("F","RES",GMRCNDX," "_GMRCTIT)
.I $L($G(GMRCCSDT)) D
..D SUB("F","RES",GMRCNDX," ")
..I (GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /es/ "_$$EXDT(GMRCCSDT)
..I '(GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /chart/ "_$$EXDT(GMRCCSDT)
..D SUB("F","RES",GMRCNDX,GMRCX)
..D:$L($G(GMRCCTIT)) SUB("F","RES",GMRCNDX," "_GMRCCTIT)
.D BLD("RES",GMRCNDX,1,0," ")
.I $L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0_" FOR "_GMRCRPT))
.I '$L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0))
.D BLD("RES",GMRCNDX,1,0," ")
.S GMRCR1=0 F S GMRCR1=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1)) Q:'GMRCR1 D
..D BLD("RES",GMRCNDX,1,0,$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1,0)))
Q
;
HDR ; Header code for form 513
;GMRCPEL ext fmt Primary Eligibiity Code
;GMRCELIG ext fmt of Patient Type defined @ FORMAT^GMRCP5A
;CVELIG marker to indicate if pt has active preference for Combat Veteran Eligibility status
;get and format eligibility info
N VAEL,VAPA,GMRCPEL,SUB,GMRCFROM
N CVELIG ;WAT
D ELIG^VADPT
D ADD^VADPT
N VASV,OEFOIF D SVC^VADPT S:(VASV(11)>0)!(VASV(12)>0)!(VASV(13)>0) OEFOIF="OEF/OIF" ;WAT 66
S GMRCPEL=$P(VAEL(1),U,2)
I $L($G(GMRCELIG)) D
.;if TYPE is Active Duty and VETERAN Y/N? is No, then call the pt Active Duty
.S:$P(VAEL(6),U,1)=5&(VAEL(4)=0) GMRCELIG=$P(VAEL(6),U,2)
F SUB=0,1 D
.N GMRCFLN
.S GMRCFLN=$P($G(^DPT(GMRCDFN,0)),U,1)
.S CVELIG=$$CVEDT^DGCV(GMRCDFN) S:$P($G(CVELIG),U,3) CVELIG="CV ELIGIBLE" ;WAT
.D BLD("HDR",SUB,1,0,GMRCDVL)
.D BLD("HDR",SUB,1,6,"MEDICAL RECORD")
.D BLD("HDR",SUB,0,39,"|")
.D BLD("HDR",SUB,0,45,"CONSULTATION SHEET")
.D BLD("HDR",SUB,1,0,GMRCDVL)
.D BLD("HDR",SUB,1,0,GMRCFLN)
.D BLD("HDR",SUB,0,45,GMRCPEL)
.D BLD("HDR",SUB,1,0,"XXX-XX-"_$P(GMRCSN,"-",3))
.D BLD("HDR",SUB,0,16,$$EXDT(GMRCDOB)_" (Age: "_GMRCAGE_")") ;89 add age
.D BLD("HDR",SUB,0,45,GMRCELIG)
.D:$G(CVELIG)["CV" BLD("HDR",SUB,1,45,CVELIG)
.D:$G(OEFOIF)="OEF/OIF" BLD("HDR",SUB,1,45,OEFOIF) ;WAT 66
;
; ADDRESS LINES 1-3
F GMRCX=1,2,3 D:$L(VAPA(GMRCX))
.D BLD("HDR",0,1,0,VAPA(GMRCX))
.;I GMRCX=1 D BLD("HDR",0,0,51,"Standard Form 513 (Rev 9-77)")
;
; CITY STATE ZIP CODE
S GMRCX=VAPA(4)_" "_$P(VAPA(5),U,2)_" "_VAPA(6)
;
I $L(VAPA(8)) S GMRCX=GMRCX_" Phone: "_VAPA(8) ; TELEPHONE (IF AVAILABLE)
I $L($P($G(^DPT(GMRCDFN,.13)),U,4)) S GMRCX=GMRCX_" Cell: "_$P($G(^DPT(GMRCDFN,.13)),U,4) ;89 add cell phone.
;
D BLD("HDR",0,1,0,GMRCX)
D BLD("HDR",0,1,0,GMRCDVL)
D BLD("HDR",0,1,0,"Consult Request: "_$$CONSRQ(GMRCIFN))
D BLD("HDR",0,1,55,"|Consult No.: "_GMRCIFN)
;
D BLD("HDR",1,1,0,GMRCEQL)
D BLD("HDR",0,1,0,GMRCDVL)
;
I $G(CMT) D BLD("HDR",0,1,27,"("_$$PRCMT^GMRCP5B(CMT)_")") Q
;
S GMRCFROM=$P($G(^SC(+$P(GMRCRD,U,6),0)),U,1)
;
I '$L(GMRCFROM) D
.N VAIN
.D INP^VADPT
.S GMRCFROM=$P($G(VAIN(4)),U,2)
.I $L($G(VAIN(5))) S GMRCFROM=GMRCFROM_" (Rm/Bd: "_$G(VAIN(5))_" )"
;No location, IFC - consulting site
I '$L(GMRCFROM),$P(GMRCRD,U,23),$P($G(GMRCRD(12)),U,5)="F" D
.I $P(GMRCRD,U,21) S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,21),.01)
.E S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,23),.01)
;
D BLD("HDR",0,1,0,"To: "_$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1))
D BLD("HDR",0,1,5,"From: "_GMRCFROM)
D BLD("HDR",0,0,49,"|Requested: "_$$EXDT($P(GMRCRD,U,7)))
;
D BLD("HDR",0,1,0,GMRCDVL)
D BLD("HDR",0,1,0,"Requesting Facility: "_$E(GMRCFAC,1,22))
I $P(GMRCRD,U,11) D BLD("HDR",0,0,45,"|ATTENTION: "_$E($$GET1^DIQ(200,+$P(GMRCRD,U,11),.01),1,21))
I $P(GMRCRD,U,23) D
. D BLD("HDR",0,1,0,"Remote Consult No.: "_GMRCINO)
. D BLD("HDR",0,1,0,"Role: "_GMRCIRL)
D BLD("HDR",0,1,0,GMRCEQL)
;
D KVAR^VADPT ;WAT 66
Q
;
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)
;
CONSRQ(IFN) ;
;
N PTR,LINK,REF,GMRCRQ
I +$P(^GMR(123,+IFN,0),U,8) D
. S GMRCRQ=$P(^GMR(123,+IFN,0),U,8)
. S GMRCRQ=$$GET1^DIQ(123.3,+GMRCRQ,.01)
. I '$L(GMRCRQ) S GMRCRQ="Procedure"
I $L($G(GMRCRQ)) Q GMRCRQ
I $L($G(^GMR(123,IFN,1.11))) D
. N SERV,TYPE
. S SERV=$$UP^XLFSTR($$GET1^DIQ(123.5,$P(^GMR(123,IFN,0),U,5),.01))
. S TYPE=$$UP^XLFSTR(^GMR(123,IFN,1.11)) I TYPE'=SERV D
. I TYPE'=SERV S GMRCRQ=$E(^GMR(123,IFN,1.11),1,36)
Q:$L($G(GMRCRQ)) GMRCRQ Q "Consult"
;
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")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCP5D 9933 printed Oct 16, 2024@17:47:23 Page 2
GMRCP5D ;SLC/DCM,RJS,JFR,WAT,DEH - Print Consult form 513 (Gather Data - Addendums, Headers, Service reports and Comments) ;01/20/17 15:19
+1 ;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,22,29,35,38,61,65,66,82,89**;Dec 27, 1997;Build 62
+2 ;Waiver #301965 submitted 2014.02.02,pending as of 2015.05.05/JDT
+3 ; MILW/RH/JDT 9/09 HDR+26,+27 concantenated age to DOB
+4 ; MILW/JDT HDR+41 add cell phone to header
+5 ; WLE added Cell phone and age to SF513
+6 ;This routine invokes the following ICR(s):
+7 ;2056 $$GET1^DIQ, 2541 $$KSP^XUPARAM, 10103 $$FMTE^XLFDT, 10104 $$UP^XLFSTR, 10061 VADPT API
+8 ;10040 ^SC(, 4156 $$CVEDT^DGCV
+9 ;
FORMAT(GMRCIFN,GMRCRD,PAGEWID) ;
+1 ;
+2 IF $LENGTH($PIECE(GMRCRD,U,15))
Begin DoDot:1
+3 IF $ORDER(^TMP("GMRCR",$JOB,"MCAR",0))
Begin DoDot:2
+4 NEW GMRCSVC
+5 SET GMRCSVC=$PIECE($GET(^GMR(123.5,+$PIECE(GMRCRD,U,5),0)),U,1)
+6 if $LENGTH(GMRCSVC)
SET GMRCSVC=GMRCSVC_" "
+7 ;
+8 ; Medicine Results?
+9 SET GMRCR0=0
FOR
SET GMRCR0=$ORDER(^TMP("GMRCR",$JOB,"MCAR",GMRCR0))
if 'GMRCR0
QUIT
Begin DoDot:3
+10 DO SUB("H","SREP",GMRCR0,$$CENTER(GMRCSVC_"Service Report #"_GMRCR0_" continued."))
+11 DO SUB("H","SREP",GMRCR0," ")
+12 DO BLD("SREP",GMRCR0,1,0,$$CENTER("Medicine Package Report"))
+13 DO BLD("SREP",GMRCR0,1,0,"")
+14 NEW LN
+15 SET LN=0
FOR
SET LN=$ORDER(^TMP("GMRCR",$JOB,"MCAR",GMRCR0,LN))
if 'LN
QUIT
Begin DoDot:4
+16 DO BLD("SREP",GMRCR0,1,0,$GET(^TMP("GMRCR",$JOB,"MCAR",GMRCR0,LN,0)))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 ; Build Processing Activities
+19 SET GMRCR0=0
FOR
SET GMRCR0=$ORDER(^GMR(123,GMRCIFN,40,GMRCR0))
if 'GMRCR0
QUIT
Begin DoDot:1
+20 NEW GMRCR1,GMRC400,CMT,USER,GMRCDT,RPRV,GMRC402,GMRCISIT
+21 SET GMRCR1=+$ORDER(^GMR(123,GMRCIFN,40,GMRCR0,0))
if GMRCR1'=1
QUIT
+22 SET GMRC400=$GET(^GMR(123,GMRCIFN,40,GMRCR0,0))
+23 SET GMRC402=$GET(^GMR(123,GMRCIFN,40,GMRCR0,2))
+24 SET CMT=$$PRCMT^GMRCP5B(+$PIECE(GMRC400,U,2))
if '$LENGTH(CMT)
QUIT
+25 SET GMRCDT=$PIECE(GMRC400,U,3)
if 'GMRCDT
SET GMRCDT=$PIECE(GMRC400,U,1)
+26 SET GMRCDT=$$EXDT(GMRCDT)_" "_$PIECE(GMRC402,U,3)
+27 ;Following lines modified in patch *38
+28 ;I $P(^GMR(123,GMRCIFN,0),U,23) D ;commented out
+29 ;.S GMRCISIT=$$GET1^DIQ(4,$P(^GMR(123,GMRCIFN,0),U,23),.01) ;commented out
+30 ;.S GMRCISIT="Entered at: "_GMRCISIT ;commented out
+31 ;ADDED
IF $LENGTH(GMRC402)
Begin DoDot:2
+32 ;ADDED
SET GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.07)
End DoDot:2
+33 ;ADDED
IF '$DATA(GMRCISIT)
Begin DoDot:2
+34 ;ADDED
SET GMRCISIT=$$KSP^XUPARAM("INST")
+35 ;ADDED
IF GMRCISIT'=""
SET GMRCISIT=$$GET1^DIQ(4,GMRCISIT,.01)
+36 ;ADDED
IF GMRCISIT=""
SET GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.05)
End DoDot:2
+37 ;ADDED
SET GMRCISIT="Entered at: "_GMRCISIT
+38 ;End of modifications for patch *38
+39 SET RPRV=$$GET1^DIQ(200,+$PIECE(GMRC400,U,4),.01)
+40 IF '$LENGTH(RPRV)
SET RPRV=$PIECE(GMRC402,U,2)
+41 if ($LENGTH(RPRV))
SET RPRV="Responsible Person: "_RPRV
+42 SET USER=$$GET1^DIQ(200,+$PIECE(GMRC400,U,5),.01)
+43 IF '$LENGTH(USER)
SET USER=$PIECE(GMRC402,U)
+44 SET USER="Entered by: "_USER_" - "_GMRCDT
+45 DO SUB("H","COM",GMRCR0,CMT_" Comment ("_USER_") continued.")
+46 DO SUB("H","COM",GMRCR0," ")
+47 DO BLD("COM",GMRCR0,1,0,"")
+48 DO BLD("COM",GMRCR0,1,0,$$CENTER("("_CMT_" Comment)"))
+49 IF $PIECE(GMRC400,U,2)=17!($PIECE(GMRC400,U,2)=25)
Begin DoDot:2
+50 NEW FWDLN,FWDRS
+51 SET FWDLN="Forwarded from: "
+52 SET FWDRS=$PIECE($GET(^GMR(123,GMRCIFN,40,GMRCR0,3)),U)
+53 IF $LENGTH(FWDRS)
SET FWDLN=FWDLN_FWDRS
+54 IF '$LENGTH(FWDRS)
SET FWDLN=FWDLN_$$GET1^DIQ(123.5,+$PIECE(GMRC400,U,6),.01)
+55 DO BLD("COM",GMRCR0,1,5,FWDLN)
End DoDot:2
+56 DO BLD("COM",GMRCR0,1,5,USER)
+57 if ($LENGTH(RPRV))
DO BLD("COM",GMRCR0,1,5,RPRV)
+58 if ($LENGTH($GET(GMRCISIT)))
DO BLD("COM",GMRCR0,1,5,GMRCISIT)
+59 ;
+60 NEW GMRCR2
SET GMRCR2=0
+61 FOR
SET GMRCR2=$ORDER(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2))
if 'GMRCR2
QUIT
Begin DoDot:2
+62 DO BLD("COM",GMRCR0,1,0,$GET(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2,0)))
End DoDot:2
End DoDot:1
+63 ;
+64 QUIT
+65 ;
ADDEND(GMRCIFN,GMRCR0,GMRCNDX,GMRCRD,PAGEWID) ;
+1 ;
+2 NEW GMRCADD,GMRCNDX,GMRCR1,GMRCV,TEXT,GMRCX
+3 ;
+4 SET GMRCADD=0
FOR
SET GMRCADD=$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0,"ADD",GMRCADD))
if 'GMRCADD
QUIT
Begin DoDot:1
+5 NEW GMRCSGNM,GMRCNMDT,GMRCTIT,GMRCMODE,GMRCCSDT,GMRCCTIT,GMRCCSGM
+6 ;
+7 FOR GMRCV="GMRCSGNM","GMRCNMDT","GMRCTIT","GMRCMODE"
Begin DoDot:2
+8 SET @GMRCV=$GET(^TMP("GMRCR",$JOB,"RES",GMRCR0,"ADD",GMRCADD,GMRCV))
End DoDot:2
+9 ;
+10 FOR GMRCV="GMRCCSDT","GMRCCTIT","GMRCCSGM","GMRCCSIG"
Begin DoDot:2
+11 SET @GMRCV=$GET(^TMP("GMRCR",$JOB,"RES",GMRCR0,"ADD",GMRCADD,GMRCV))
End DoDot:2
+12 SET GMRCNDX=$ORDER(^TMP("GMRC",$JOB,"OUTPUT","RES"," "),-1)+1
+13 IF $LENGTH($GET(GMRCRPT))
DO SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" for "_GMRCRPT_" continued.")
+14 IF '$LENGTH($GET(GMRCRPT))
DO SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" continued.")
+15 DO SUB("H","RES",GMRCNDX," ")
+16 IF $LENGTH($GET(GMRCSGNM))
Begin DoDot:2
+17 DO SUB("F","RES",GMRCNDX," ")
+18 IF (GMRCMODE="electronic")
SET GMRCX=" Addendum Signature: "_GMRCSGNM_" /es/ "_$$EXDT($GET(GMRCNMDT))
+19 IF '(GMRCMODE="electronic")
SET GMRCX=" Addendum Author: "_GMRCSGNM
if $LENGTH($GET(GMRCNMDT))
SET GMRCX=GMRCX_" Last edited: "_$$EXDT(GMRCNMDT)
+20 DO SUB("F","RES",GMRCNDX,GMRCX)
+21 if $LENGTH($GET(GMRCTIT))
DO SUB("F","RES",GMRCNDX," "_GMRCTIT)
End DoDot:2
+22 IF $LENGTH($GET(GMRCCSDT))
Begin DoDot:2
+23 DO SUB("F","RES",GMRCNDX," ")
+24 IF (GMRCCSGM="electronic")
SET GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /es/ "_$$EXDT(GMRCCSDT)
+25 IF '(GMRCCSGM="electronic")
SET GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /chart/ "_$$EXDT(GMRCCSDT)
+26 DO SUB("F","RES",GMRCNDX,GMRCX)
+27 if $LENGTH($GET(GMRCCTIT))
DO SUB("F","RES",GMRCNDX," "_GMRCCTIT)
End DoDot:2
+28 DO BLD("RES",GMRCNDX,1,0," ")
+29 IF $LENGTH($GET(GMRCRPT))
DO BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0_" FOR "_GMRCRPT))
+30 IF '$LENGTH($GET(GMRCRPT))
DO BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0))
+31 DO BLD("RES",GMRCNDX,1,0," ")
+32 SET GMRCR1=0
FOR
SET GMRCR1=$ORDER(^TMP("GMRCR",$JOB,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1))
if 'GMRCR1
QUIT
Begin DoDot:2
+33 DO BLD("RES",GMRCNDX,1,0,$GET(^TMP("GMRCR",$JOB,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1,0)))
End DoDot:2
End DoDot:1
+34 QUIT
+35 ;
HDR ; Header code for form 513
+1 ;GMRCPEL ext fmt Primary Eligibiity Code
+2 ;GMRCELIG ext fmt of Patient Type defined @ FORMAT^GMRCP5A
+3 ;CVELIG marker to indicate if pt has active preference for Combat Veteran Eligibility status
+4 ;get and format eligibility info
+5 NEW VAEL,VAPA,GMRCPEL,SUB,GMRCFROM
+6 ;WAT
NEW CVELIG
+7 DO ELIG^VADPT
+8 DO ADD^VADPT
+9 ;WAT 66
NEW VASV,OEFOIF
DO SVC^VADPT
if (VASV(11)>0)!(VASV(12)>0)!(VASV(13)>0)
SET OEFOIF="OEF/OIF"
+10 SET GMRCPEL=$PIECE(VAEL(1),U,2)
+11 IF $LENGTH($GET(GMRCELIG))
Begin DoDot:1
+12 ;if TYPE is Active Duty and VETERAN Y/N? is No, then call the pt Active Duty
+13 if $PIECE(VAEL(6),U,1)=5&(VAEL(4)=0)
SET GMRCELIG=$PIECE(VAEL(6),U,2)
End DoDot:1
+14 FOR SUB=0,1
Begin DoDot:1
+15 NEW GMRCFLN
+16 SET GMRCFLN=$PIECE($GET(^DPT(GMRCDFN,0)),U,1)
+17 ;WAT
SET CVELIG=$$CVEDT^DGCV(GMRCDFN)
if $PIECE($GET(CVELIG),U,3)
SET CVELIG="CV ELIGIBLE"
+18 DO BLD("HDR",SUB,1,0,GMRCDVL)
+19 DO BLD("HDR",SUB,1,6,"MEDICAL RECORD")
+20 DO BLD("HDR",SUB,0,39,"|")
+21 DO BLD("HDR",SUB,0,45,"CONSULTATION SHEET")
+22 DO BLD("HDR",SUB,1,0,GMRCDVL)
+23 DO BLD("HDR",SUB,1,0,GMRCFLN)
+24 DO BLD("HDR",SUB,0,45,GMRCPEL)
+25 DO BLD("HDR",SUB,1,0,"XXX-XX-"_$PIECE(GMRCSN,"-",3))
+26 ;89 add age
DO BLD("HDR",SUB,0,16,$$EXDT(GMRCDOB)_" (Age: "_GMRCAGE_")")
+27 DO BLD("HDR",SUB,0,45,GMRCELIG)
+28 if $GET(CVELIG)["CV"
DO BLD("HDR",SUB,1,45,CVELIG)
+29 ;WAT 66
if $GET(OEFOIF)="OEF/OIF"
DO BLD("HDR",SUB,1,45,OEFOIF)
End DoDot:1
+30 ;
+31 ; ADDRESS LINES 1-3
+32 FOR GMRCX=1,2,3
if $LENGTH(VAPA(GMRCX))
Begin DoDot:1
+33 DO BLD("HDR",0,1,0,VAPA(GMRCX))
+34 ;I GMRCX=1 D BLD("HDR",0,0,51,"Standard Form 513 (Rev 9-77)")
End DoDot:1
+35 ;
+36 ; CITY STATE ZIP CODE
+37 SET GMRCX=VAPA(4)_" "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
+38 ;
+39 ; TELEPHONE (IF AVAILABLE)
IF $LENGTH(VAPA(8))
SET GMRCX=GMRCX_" Phone: "_VAPA(8)
+40 ;89 add cell phone.
IF $LENGTH($PIECE($GET(^DPT(GMRCDFN,.13)),U,4))
SET GMRCX=GMRCX_" Cell: "_$PIECE($GET(^DPT(GMRCDFN,.13)),U,4)
+41 ;
+42 DO BLD("HDR",0,1,0,GMRCX)
+43 DO BLD("HDR",0,1,0,GMRCDVL)
+44 DO BLD("HDR",0,1,0,"Consult Request: "_$$CONSRQ(GMRCIFN))
+45 DO BLD("HDR",0,1,55,"|Consult No.: "_GMRCIFN)
+46 ;
+47 DO BLD("HDR",1,1,0,GMRCEQL)
+48 DO BLD("HDR",0,1,0,GMRCDVL)
+49 ;
+50 IF $GET(CMT)
DO BLD("HDR",0,1,27,"("_$$PRCMT^GMRCP5B(CMT)_")")
QUIT
+51 ;
+52 SET GMRCFROM=$PIECE($GET(^SC(+$PIECE(GMRCRD,U,6),0)),U,1)
+53 ;
+54 IF '$LENGTH(GMRCFROM)
Begin DoDot:1
+55 NEW VAIN
+56 DO INP^VADPT
+57 SET GMRCFROM=$PIECE($GET(VAIN(4)),U,2)
+58 IF $LENGTH($GET(VAIN(5)))
SET GMRCFROM=GMRCFROM_" (Rm/Bd: "_$GET(VAIN(5))_" )"
End DoDot:1
+59 ;No location, IFC - consulting site
+60 IF '$LENGTH(GMRCFROM)
IF $PIECE(GMRCRD,U,23)
IF $PIECE($GET(GMRCRD(12)),U,5)="F"
Begin DoDot:1
+61 IF $PIECE(GMRCRD,U,21)
SET GMRCFROM=$$GET1^DIQ(4,$PIECE(GMRCRD,U,21),.01)
+62 IF '$TEST
SET GMRCFROM=$$GET1^DIQ(4,$PIECE(GMRCRD,U,23),.01)
End DoDot:1
+63 ;
+64 DO BLD("HDR",0,1,0,"To: "_$PIECE($GET(^GMR(123.5,+$PIECE(GMRCRD,U,5),0)),U,1))
+65 DO BLD("HDR",0,1,5,"From: "_GMRCFROM)
+66 DO BLD("HDR",0,0,49,"|Requested: "_$$EXDT($PIECE(GMRCRD,U,7)))
+67 ;
+68 DO BLD("HDR",0,1,0,GMRCDVL)
+69 DO BLD("HDR",0,1,0,"Requesting Facility: "_$EXTRACT(GMRCFAC,1,22))
+70 IF $PIECE(GMRCRD,U,11)
DO BLD("HDR",0,0,45,"|ATTENTION: "_$EXTRACT($$GET1^DIQ(200,+$PIECE(GMRCRD,U,11),.01),1,21))
+71 IF $PIECE(GMRCRD,U,23)
Begin DoDot:1
+72 DO BLD("HDR",0,1,0,"Remote Consult No.: "_GMRCINO)
+73 DO BLD("HDR",0,1,0,"Role: "_GMRCIRL)
End DoDot:1
+74 DO BLD("HDR",0,1,0,GMRCEQL)
+75 ;
+76 ;WAT 66
DO KVAR^VADPT
+77 QUIT
+78 ;
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 ;
CONSRQ(IFN) ;
+1 ;
+2 NEW PTR,LINK,REF,GMRCRQ
+3 IF +$PIECE(^GMR(123,+IFN,0),U,8)
Begin DoDot:1
+4 SET GMRCRQ=$PIECE(^GMR(123,+IFN,0),U,8)
+5 SET GMRCRQ=$$GET1^DIQ(123.3,+GMRCRQ,.01)
+6 IF '$LENGTH(GMRCRQ)
SET GMRCRQ="Procedure"
End DoDot:1
+7 IF $LENGTH($GET(GMRCRQ))
QUIT GMRCRQ
+8 IF $LENGTH($GET(^GMR(123,IFN,1.11)))
Begin DoDot:1
+9 NEW SERV,TYPE
+10 SET SERV=$$UP^XLFSTR($$GET1^DIQ(123.5,$PIECE(^GMR(123,IFN,0),U,5),.01))
+11 SET TYPE=$$UP^XLFSTR(^GMR(123,IFN,1.11))
IF TYPE'=SERV
Begin DoDot:2
End DoDot:2
+12 IF TYPE'=SERV
SET GMRCRQ=$EXTRACT(^GMR(123,IFN,1.11),1,36)
End DoDot:1
+13 if $LENGTH($GET(GMRCRQ))
QUIT GMRCRQ
QUIT "Consult"
+14 ;
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 ;
