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

GMRCP5D.m

Go to the documentation of this file.
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")
 ;