1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 3/31/2017 1:06:26 PM Central Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

1.1 Files compared

#	Location	File	Last Modified
1	EPIP_submissions.zip\EPIP_submissions\docs\GMRC_3.0_89	EPIP_Remediation_Plan_(GMRC_3.0_89).docx	Fri Mar 31 16:50:10 2017 UTC
2	EPIP_submissions.zip\EPIP_submissions\docs\GMRC_3.0_89	EPIP_Remediation_Plan_(GMRC_3.0_89).docx	Fri Mar 31 17:46:40 2017 UTC

1.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	4	4818
Changed	3	11
Inserted	0	0
Removed	0	0

1.3 Comparison options

Whitespace
Character case	Differences in character case are significant
Line endings	Differences in line endings (`CR` and `LF` characters) are ignored
CR/LF characters	Not shown in the comparison detail

1.4 Active regular expressions

No regular expressions were active.

1.5 Comparison detail

	1	Existing P roduct Int ake Progra m (EPIP)
	2	Patch GMRC 3.089
	3	Remediatio n Plan
	4
	5	Department of Vetera ns Affairs
	6	March 2017
	7	Version 3. 0
	8
	9
	10
	11	Revision H istory
	12	Date
	13	Version
	14	Descriptio n
	15	Author
	16	03/21/2017
	17	3.0
	18	Updated Pa tch Descri ption, Pro ject Sched ule, Code Remediatio n, and Doc umentation Remediati on section s and both Appendice s
	19	EPIP Proje ct Team
	20	12/22/2016
	21	2.0
	22	Updated en tire docum ent
	23	EPIP Proje ct Team
	24	11/28/2016
	25	1.0
	26	Initial ve rsion
	27	EPIP Proje ct Team
	28
	29
	30
	31
	32	Table of C ontents
	33	1.Introduc tion1
	34	2.Purpose1
	35	3.Patch De scription1
	36	3.1.Needs and Requir ements2
	37	4.Points o f Contact3
	38	5.Code Rem ediation3
	39	5.1.Standa rds and Co nventions3
	40	5.2.Review and Analy sis3
	41	5.3.Coding Changes3
	42	6.Testing4
	43	6.1.Test P lan4
	44	6.2.Test E nvironment 4
	45	6.3.Test R eadiness R eview4
	46	6.4.Testin g Phases5
	47	6.4.1.Unit Testing5
	48	6.4.2.Comp onent Inte gration an d Systems Testing (C I/ST)5
	49	6.4.3.Func tional Tes ting5
	50	6.4.4.Regr ession Tes ting5
	51	6.4.5.Sect ion 508 Co mpliance T esting5
	52	7.Document ation Reme diation5
	53	7.1.User G uides6
	54	7.2.Instal lation Gui des6
	55	7.3.Techni cal Manual s6
	56	7.4.Operat ions Manua ls6
	57	8.Project Reporting6
	58	9.Project Schedule6
	59	10.Deploym ent6
	60	11.Sustain ment Requi rements6
	61	12.Mainten ance and K nowledge T ransfer7
	62	Appendix A :XINDEX Li sting for MUMPS Code Changes8
	63	Appendix B :Source Co de Changes 9
	64
	65
	66
	67	Introducti on
	68	The Depart ment of Ve terans Aff airs (VA) currently utilizes t he Veteran s Health I nformation Systems a nd Technol ogy Archit ecture (Vi stA) suite of applic ations to provide cl inical, fi nancial, i nfrastruct ure, and m anagement tools. The process o f advancin g “Class 3 ” field-de veloped Vi stA softwa re to “Cla ss 1” nati onally-dis tributed s tatus is r eferred to as the Ex isting Pro duct Intak e Program (EPIP). Th e VA’s goa l is to su pplement o ngoing act ivities as sociated w ith evalua ting and a dvancing f ield-devel oped softw are to a s tate that meets nati onal stand ards and f acilitates release f or Veteran s Health A dministrat ion (VHA)- wide use.
	69	Purpose
	70	The purpos e of this document i s to fully describe the remedi ation plan to be use d for the successful remediati on of the intake pro duct code to be depl oyed as pa tch GMRC3 .089. Thi s patch ad dresses th e followin g NSRs:
	71	NSR2008031 2 Post-Hoc Consult/C losure Not e Associat ion Tool
	72	This NSR h as been im plemented locally at the VA Me dical Cent er in San Francisco CA.
	73	NSR2015100 5 Print Ve terans Cel l Phone Nu mber and A ge on Cons ult Form
	74	This NSR h as been im plemented locally at the VA Me dical Cent er in Milw aukee WI.
	75	NSR2015100 2 Secondar y Consult Service Pr inters
	76	This NSR h as been im plemented locally at the VA Me dical Cent ers in Hou ston TX an d Hines IL .
	77	Patch Desc ription
	78	GMRC3.08 9 provides the follo wing enhan cements to VistA:
	79	Improves t he process of managi ng pending consults by providi ng a Consu lt Closure Tool that identifie s consult requests t hat are in correctly left in Pe nding stat us and eff iciently c loses out those cons ults. Curr ent VistA tools prov ide lists of patient s with pen ding consu lts, but d o not prov ide the ab ility to a ct on thos e lists di rectly. Th e use of n on-consult class Tex t Integrat ion Utilit y (TIU) no tes, dupli cate consu lt request s, and oth er workaro und option s to close out consu lt request s leads to errors in consult c ompletion rates and creates re dundant wo rk during consult cl ean-up act ions. Curr ently, the ‘administ rative com pletion’ o ption in t he Compute rized Pati ent Record System (C PRS) is th e only met hod for cl osing out completed consults w ith incorr ect note t itles.
	80	This modif ication ad ds a new o ption [GMR C CONSULT CLOSURE TO OL] to the VistA Con sult Manag ement [GMR C MGR] men u. The Con sult Closu re Tool me nu provide s Edit Con figuration and Run C onfigurati on options .
	81	The Edit C onfigurati on option is used to create or edit a co nsult clos ure Config uration fo r a specif ied CPRS T eam. The C onfigurati on consist s of searc h paramete rs—includi ng Clinic, Procedure , Service, and Order Item—to b e used in finding pe nding cons ults, as w ell as a l ist of exi sting TIU notes to b e used to close out the consul ts. The Ru n Configur ation opti on can the n be used to: 1.) ge nerate a p rinted lis t of patie nts with p ending con sults that meet the parameters specified in the Co nfiguratio n and popu late the T eam list i n CPRS, or 2.) immed iately res olve and c lose each of the pen ding consu lts by sel ecting a T IU note to associate with it.
	82	Provides a veteran’s cell phon e number a nd age (fr om the PAT IENT file (#2)) on t he Consult ation Form (SF-513) in CPRS. M any vetera ns do not have a hom e phone nu mber, so a cell phon e number i s vital in formation if it is t he primary contact n umber. Pri nting a ve teran’s ag e on the f orm elimin ates the c hance of a math erro r being ma de by the provider w hen consid ering trea tment opti ons that a re reliant on age.
	83	Enables a Consultati on Form (S F-513) to be simulta neously pr inted to p rinters at two diffe rent locat ions by ad ding a SEC ONDARY PRI NTER field (#689) to the REQUE ST SERVICE S file (#1 23.5). The modificat ion allows both serv ices to be notified of a new c onsult at the same t ime, allow ing repres entatives at both lo cations to begin the ir reviews concurren tly.
	84	Needs and Requiremen ts
	85	The Needs and Requir ements for the NSRs addressed in this re mediation are:
	86	NSR2008031 2 Post-Hoc Consult/C losure Not e Associat ion Tool:
	87	NEED 38670 5: Post HO C - Pendin g Consults Managemen t - For Us ers of con sult packa ge who nee d to manag e pending consults t he automat ion of the process o f reviewin g and clos ing pendin g consults using an interactiv e tool tha t displays a list of pending c onsults, a ssociated appointmen ts, and as sociated p rogress no te.
	88	REQUIREMEN T 396002: Create act ionable pa tient list s - As a u ser involv ed in clos ing pendin g consults I need to be able t o create a ctionable lists by c onfiguring such item s as maxim um number of days be tween the consult an d the appo intment, m aximum num ber of day s between the appoin tment and the note, and speci. (sic)
	89	NSR 201510 05 Print V eterans Ce ll Phone N umber and Age on Con sult Form:
	90	NEED 63473 1: View Ve teran's Ce ll Phone N umber on t he Printed Consult F orm - As a user of c onsults I need to be able to v iew the Ve teran's ce ll phone n umber on t he printed Consult F orm, along with the currently displayed contact in formation, so that I can conta ct the Vet eran using informati on printed in the he ader and n ot delay c are.
	91	NEED 63473 2: View th e Veteran' s Age on t he Printed Consult F orm - As a user of c onsults I need to be able to v iew the Ve teran's ag e on the p rinted con sult form so that I do not hav e to calcu late the a ge from th e date of birth for the age de pendent pr otocols of some proc edures.
	92	NSR2015100 2 Secondar y Consult Service Pr inters:
	93	NEED 62108 4: Print C onsult At Two Locati ons - As a provider who reques ts consult s I would like consu lts that r equire two different services to review and approv e to print on.
	94	Points of Contact
	95	The VA Poi nt of Cont act (POC) for NSR200 80312 Post -Hoc Consu lt/Closure Note Asso ciation To ol is
	96	The VA POC for NSR 2 0151005 Pr int Vetera ns Cell Ph one Number and Age o n Consult Form is
	97	The VA POC for NSR20 151002 Sec ondary Con sult Servi ce Printer s is Code Re m e d i a ti o n

	98	Leidos wil l review a nd analyze the intak e product code for c ompliance with codin g standard s, pointer s, shared tables, de pendencies , and any interferen ce with Vi stA system s.
	99	Standards and Conven tions
	100	Leidos wil l referenc e the website fo r applicab le documen ts and wil l adhere t o VA stand ards to co mplete the analysis of this in take produ ct. The ou tput of th e VA XINDE X utility will be us ed to anal yze the MU MPS source code and document t he affecte d routines (see Appe ndix A).
	101	The MUMPS coding sta ndards web site http: //71.174.6 2.16/Demo/ AnnoStd wi ll also be used to e nsure that the remed iated code conforms to VA stan dards.
	102	Review and Analysis
	103	Review and analysis of this in take produ ct involve s two part s: 1) veri fication t hat the so urce code changes sp ecified in this docu ment provi de the des ired effec t, and 2) verificati on that th e source c ode change s do not a dversely a ffect any other Vist A or CPRS functional ity.
	104	Testing wi ll be perf ormed to v alidate th at the int ended effe ct of thes e products is implem ented, and that no o ther VistA or CPRS G raphical U ser Interf ace (GUI) functional ity is adv ersely aff ected.
	105	Coding Cha nges
	106	The coding changes r equired fo r NSR20080 312 Post-H oc Consult /Closure N ote Associ ation Tool are in th e followin g MUMPS ro utines:
	107	Modified r outines: N one
	108	New routin es: GMRCCA , GMRCCB, GMRCCC, GM RCCD, GMRC CX, GMRCCY
	109	The coding changes r equired fo r NSR 2015 1005 Print Veterans Cell Phone Number an d Age on C onsult For m are in t he followi ng MUMPS r outines:
	110	Modified r outines: G MRCP5D
	111	New routin es: None
	112	The coding changes r equired fo r NSR20151 002 Second ary Consul t Service Printers a re in the following MUMPS rout ines:
	113	Modified r outines: G MRCUTL1
	114	New routin es: GMRCZU TL
	115	A detailed analysis of the cod ing change s is provi ded in App endix B.
	116	Testing
	117	Leidos wil l perform all testin g-related activities to ensure that the remediated code meet s the expe ctations o f the VA b usiness ow ner.
	118	Test Plan
	119	Leidos wil l configur e the test environme nt, provid e code mod ifications and end-t o-end test ing, and d eliver app licable te sting docu mentation, following Veteran-f ocused Int egration P rocess (VI P) guideli nes.
	120	The Leidos developer will modi fy the sof tware purs uant to th e VA stand ards defin ed in the Standards and Conven tions sect ion of thi s document , and will conduct f ull unit t esting of the functi onality an d verify p erformance of all so ftware cod e before i t is relea sed to Lei dos SQA. S QA will th en perform all appli cable test ing types as describ ed in the Testing Ph ases secti on of this document. The devel oper and S QA will re solve prob lems and a ddress iss ues as the y arise du ring testi ng and wil l document issues us ing the Ra tional Tea m Concert (RTC) defe ct trackin g tool.
	121	Test Envir onment
	122	Within fiv e working days of ap proval of this Remed iation Pla n, the dev eloper wil l configur e the deve lopment/te st environ ment on an Austin In formation Technology Center (A ITC) serve r or other VA-approv ed develop ment/test environmen t used for this inta ke product and insta ll the rem ediated Ke rnel Insta llation an d Distribu tion Syste m (KIDS) b uild. The environmen t will be restored t o its orig inal basel ine state by the Vis tA system administra tor after developmen t testing is complet ed, follow ed by inst allation o f the reme diated sof tware.
	123	Upon notif ication fr om the dev eloper of test envir onment rea diness, SQ A will com mence with planned t esting act ivities. T he SQA tes t executio n and repo rting docu mentation will resid e in the R ational Qu ality Mana ger (RQM) “EPIP” Pro ject. In o rder to pe rform test ing of thi s VistA mo dification , the foll owing tool s will be leveraged: RQM, Refl ections em ulator, CP RS GUI v31 (1.0.30.7 5), and Sn agIt.
	124	Test Readi ness Revie w
	125	Leidos wil l conduct a Test Rea diness Rev iew (TRR) at the con clusion of unit test ing to ver ify the co ntents of the softwa re to be t ested, the test sche dule, test environme nts, test participan ts, and as sociated l ogistics. Leidos wil l provide an agenda prior to t he TRR and written m inutes aft er complet ion of the TRR, in a ccordance with the P erformance Work Stat ement (PWS ).
	126	Testing Ph ases
	127	Leidos wil l perform developmen t and SQA testing ac tivities i n phases, and will p rovide all required testing do cumentatio n.
	128	Unit Testi ng
	129	The develo per will c onduct uni t testing of individ ual units of source code to de termine if they are fit for us e.
	130	Component Integratio n and Syst ems Testin g (CI/ST)
	131	Component integratio n and syst ems testin g will be conducted by SQA to ensure tha t connecti vity to th e VistA ap plication exists and is functi oning norm ally. SQA will recor d Passed/F ailed outc omes and c apture dis played con tent to do cument the system te sting effo rt.
	132	Functional Testing
	133	Functional testing w ill be per formed by SQA to tes t the code modificat ions. This testing w ill ensure that the software f unctionali ty is in a lignment w ith the Go vernment F urnished I nformation . SQA will record Pa ssed/Faile d outcomes and captu re display ed content to docume nt the fun ctional te sting effo rt.
	134	Regression Testing
	135	Regression testing w ill be per formed by SQA to ens ure that t he remedia ted code d oes not in troduce er rors to ex isting fun ctionality . The regr ession tes t framewor k will be kept up-to -date with manual te st cases a nd test sc ripts defi ning the i nputs and expected o utcomes. S QA will re cord Passe d/Failed o utcomes an d capture displayed content to document the regres sion testi ng effort.
	136	Section 50 8 Complian ce Testing
	137	Section 50 8 testing will be pe rformed on VistA and CPRS code when new CPRS GUI c hanges are introduce d by the d eveloper. The VA-rec ommended A ssistive T echnology tool, JAWS , will be used to co nduct the 508 testin g. Test re sults and related do cumentatio n will be submitted to the VA Section 50 8 team in accordance with the VA 508 tes ting requi rements. D efects fou nd during testing wi ll be asse ssed and r emediated by the dev eloper.
	138	Documentat ion Remedi ation
	139	Leidos wil l review e xisting VA documenta tion for p ossible im pact as a result of this remed iation eff ort, and w ill make u pdates whe re applica ble.
	140	To determi ne the exi sting VA d ocumentati on that re quires mod ification, Leidos wi ll conduct a thoroug h review o f the docu ments curr ently avai lable from the VA So ftware Doc ument Libr ary (VDL) located at Keyword se arches usi ng terms r elevant to this reme diation ef fort will be used to identify documents that might be impact ed; those documents were will then be re viewed in their enti rety for a ny needed revisions.
	141	The follow ing sectio ns outline the VDL d ocuments t o be revis ed for thi s remediat ion, as we ll as the Release No tes to be provided b y Leidos.
	142	User Guide s
	143	The follow ing User G uide will be updated in the VD L:
	144	Consult/Re quest Trac king User Manual Ver sion 3.0
	145	Installati on Guides
	146	The Nation al Patch M odule Patc h Descript ion docume nt for thi s remediat ion will p rovide the procedure for insta lling KIDS packages migrated f rom the te st environ ment to th e VA Pre-P roduction environmen ts. Theref ore, no In stallation Guides wi ll be upda ted.
	147	Technical Manuals
	148	The follow ing Techni cal Manual will be u pdated in the VDL:
	149	Consult/Re quest Trac king Techn ical Manua l Version 3.0
	150	Operations Manuals
	151	No Operati ons Manual s require revision a s a result of this m odificatio n.
	152	Project Re porting
	153	Leidos wil l provide interim pr ogress upd ates durin g daily Sc rum calls and weekly managemen t calls wi th VA repr esentative s.
	154	Project Sc hedule
	155	Leidos wil l follow t he Scrum A gile metho dology for software developmen t. It is a nticipated that this patch wil l require five 2-wee k sprints.
	156	Deployment
	157	Leidos wil l create a KIDS pack age contai ning the s oftware ch anges nece ssary to f ulfill the requireme nts for th is remedia tion effor t. A KIDS package, a long with all relate d document ation, wil l be deliv ered to th e Contract ing Office Represent ative (COR ) for acce ptance. If accepted, the KIDS package ca n then be released f or nationa l VA consu mption; ot herwise, L eidos will correct a ny defects found and repeat th e necessar y remediat ion activi ties.
	158	Sustainmen t Requirem ents
	159	Leidos wil l provide maintenanc e support for 60 day s to the V A to suppo rt the fin al Class 1 product a fter it is nationall y released .
	160	Maintenanc e and Know ledge Tran sfer
	161	To facilit ate contin uous proce ss improve ment, Leid os will de liver Spri nt Review and Retros pective sl ides and a Lessons L earned Rep ort to VA upon compl etion of t he final s print.
	162	XINDEX Lis ting for M UMPS Code Changes
	163	The XINDEX tool is t he standar d tool use d by the V A to analy ze MUMPS s ource code . Followin g is a lis ting of th e results of the XIN DEX analys is of the affected r outines.
	164
	165
	166	V . A. C R O S S R E F E R E N C E R 7. 3
	167	[2008 V A Standard s & Conven tions]
	168	UC I: VISTA C PU: ROU Mar 15, 2 017@11:37: 32
	169	Routines: 9 Faux Ro utines: 0
	170
	171	GMRCCA GMRCCB GMRCCC GMRCCD GMRCCX GMRCCY GMRCP5D GMRCUTL1
	172	GMRCZUTL
	173
	174	--- CROSS REFERENCIN G ---
	175
	176	Press r eturn to c ontinue:
	177
	178	Compiled l ist of Err ors and Wa rnings Mar 15, 20 17@11:37:3 2 page 1
	179	No errors or warning s to repor t
	180
	181
	182	--- END -- -
	183
	184
	185	Source Cod e Changes
	186	This appen dix displa ys the Vis tA code be fore and a fter the u pdates req uired for this code modificati on were im plemented. The follo wing routi nes were a ffected:
	187	Modified r outines: G MRCP5D, GM RCUTL1
	188	New routin es: GMRCCA , GMRCCB, GMRCCC, GM RCCD, GMRC CX, GMRCCY , GMRCZUTL
	189	GMRCP5D
	190	Before:
	191	GMRCP5D ;S LC/DCM,RJS ,JFR,WAT,D EH - Print Consult f orm 513 (G ather Data - Addendu ms, Header s, Service reports a nd Comment s) ;03/18/ 09 15:00
	192	;;3.0;CON SULT/REQUE ST TRACKIN G;4,12,1 5,22,29,35 ,38,61,65, 66,82;De c 27, 1997 ;Build 11
	193	;This rou tine invok es the fol lowing ICR (s):
	194	;2056 $$G ET1^DIQ, 2 541 $$KSP^ XUPARAM, 1 0103 $$FMT E^XLFDT, 1 0104 $$UP^ XLFSTR, 10 061 VADPT API
	195	;10040 ^S C(, 4156 $ $CVEDT^DGC V
	196	;
	197	FORMAT(GMR CIFN,GMRCR D,PAGEWID) ;
	198	;
	199	I $L($P(G MRCRD,U,15 )) D
	200	.I $O(^TM P("GMRCR", $J,"MCAR", 0)) D
	201	..N GMRCS VC
	202	..S GMRCS VC=$P($G(^ GMR(123.5, +$P(GMRCRD ,U,5),0)), U,1)
	203	..S:$L(GM RCSVC) GMR CSVC=GMRCS VC_" "
	204	..;
	205	..; Medic ine Result s?
	206	..S GMRCR 0=0 F S G MRCR0=$O(^ TMP("GMRCR ",$J,"MCAR ",GMRCR0)) Q:'GMRCR0 D
	207	...D SUB( "H","SREP" ,GMRCR0,$$ CENTER(GMR CSVC_"Serv ice Report #"_GMRCR0 _" continu ed."))
	208	...D SUB( "H","SREP" ,GMRCR0," ")
	209	...D BLD( "SREP",GMR CR0,1,0,$$ CENTER("Me dicine Pac kage Repor t"))
	210	...D BLD( "SREP",GMR CR0,1,0,"" )
	211	...N LN
	212	...S LN=0 F S LN=$ O(^TMP("GM RCR",$J,"M CAR",GMRCR 0,LN)) Q:' LN D
	213	....D BLD ("SREP",GM RCR0,1,0,$ G(^TMP("GM RCR",$J,"M CAR",GMRCR 0,LN,0)))
	214	;
	215	; Build P rocessing Activities
	216	S GMRCR0= 0 F S GMR CR0=$O(^GM R(123,GMRC IFN,40,GMR CR0)) Q:'G MRCR0 D
	217	.N GMRCR1 ,GMRC400,C MT,USER,GM RCDT,RPRV, GMRC402,GM RCISIT
	218	.S GMRCR1 =+$O(^GMR( 123,GMRCIF N,40,GMRCR 0,0)) Q:GM RCR1'=1
	219	.S GMRC40 0=$G(^GMR( 123,GMRCIF N,40,GMRCR 0,0))
	220	.S GMRC40 2=$G(^GMR( 123,GMRCIF N,40,GMRCR 0,2))
	221	.S CMT=$$ PRCMT^GMRC P5B(+$P(GM RC400,U,2) ) Q:'$L(CM T)
	222	.S GMRCDT =$P(GMRC40 0,U,3) S:' GMRCDT GMR CDT=$P(GMR C400,U,1)
	223	.S GMRCDT =$$EXDT(GM RCDT)_" "_ $P(GMRC402 ,U,3)
	224	.;Followi ng lines m odified in patch *38
	225	.;I $P(^G MR(123,GMR CIFN,0),U, 23) D ;co mmented ou t
	226	.;.S GMRC ISIT=$$GET 1^DIQ(4,$P (^GMR(123, GMRCIFN,0) ,U,23),.01 ) ;commen ted out
	227	.;.S GMRC ISIT="Ente red at: "_ GMRCISIT ;commented out
	228	.I $L(GMR C402) D ; ADDED
	229	..S GMRCI SIT=$$GET1 ^DIQ(123,G MRCIFN,.07 ) ;ADDED
	230	.I '$D(GM RCISIT) D ;ADDED
	231	..S GMRCI SIT=$$KSP^ XUPARAM("I NST") ;AD DED
	232	..I GMRCI SIT'="" S GMRCISIT=$ $GET1^DIQ( 4,GMRCISIT ,.01) ;AD DED
	233	..I GMRCI SIT="" S G MRCISIT=$$ GET1^DIQ(1 23,GMRCIFN ,.05) ;AD DED
	234	.S GMRCIS IT="Entere d at: "_GM RCISIT ;A DDED
	235	.;End of modificati ons for pa tch *38
	236	.S RPRV=$ $GET1^DIQ( 200,+$P(GM RC400,U,4) ,.01)
	237	.I '$L(RP RV) S RPRV =$P(GMRC40 2,U,2)
	238	.S:($L(RP RV)) RPRV= "Responsib le Person: "_RPRV
	239	.S USER=$ $GET1^DIQ( 200,+$P(GM RC400,U,5) ,.01)
	240	.I '$L(US ER) S USER =$P(GMRC40 2,U)
	241	.S USER=" Entered by : "_USER_" - "_GMRCD T
	242	.D SUB("H ","COM",GM RCR0,CMT_" Comment ( "_USER_") continued. ")
	243	.D SUB("H ","COM",GM RCR0," ")
	244	.D BLD("C OM",GMRCR0 ,1,0,"")
	245	.D BLD("C OM",GMRCR0 ,1,0,$$CEN TER("("_CM T_" Commen t)"))
	246	.I $P(GMR C400,U,2)= 17!($P(GMR C400,U,2)= 25) D
	247	.. N FWDL N,FWDRS
	248	.. S FWDL N="Forward ed from: "
	249	.. S FWDR S=$P($G(^G MR(123,GMR CIFN,40,GM RCR0,3)),U )
	250	.. I $L(F WDRS) S FW DLN=FWDLN_ FWDRS
	251	.. I '$L( FWDRS) S F WDLN=FWDLN _$$GET1^DI Q(123.5,+$ P(GMRC400, U,6),.01)
	252	.. D BLD( "COM",GMRC R0,1,5,FWD LN)
	253	.D BLD("C OM",GMRCR0 ,1,5,USER)
	254	.D:($L(RP RV)) BLD(" COM",GMRCR 0,1,5,RPRV )
	255	.D:($L($G (GMRCISIT) )) BLD("CO M",GMRCR0, 1,5,GMRCIS IT)
	256	.;
	257	.N GMRCR2 S GMRCR2= 0
	258	.F S GMR CR2=$O(^GM R(123,GMRC IFN,40,GMR CR0,GMRCR1 ,GMRCR2)) Q:'GMRCR2 D
	259	..D BLD(" COM",GMRCR 0,1,0,$G(^ GMR(123,GM RCIFN,40,G MRCR0,GMRC R1,GMRCR2, 0)))
	260	;
	261	Q
	262	;
	263	ADDEND(GMR CIFN,GMRCR 0,GMRCNDX, GMRCRD,PAG EWID) ;
	264	;
	265	N GMRCADD ,GMRCNDX,G MRCR1,GMRC V,TEXT,GMR CX
	266	;
	267	S GMRCADD =0 F S GM RCADD=$O(^ TMP("GMRCR ",$J,"RES" ,GMRCR0,"A DD",GMRCAD D)) Q:'GMR CADD D
	268	.N GMRCSG NM,GMRCNMD T,GMRCTIT, GMRCMODE,G MRCCSDT,GM RCCTIT,GMR CCSGM
	269	.;
	270	.F GMRCV= "GMRCSGNM" ,"GMRCNMDT ","GMRCTIT ","GMRCMOD E" D
	271	..S @GMRC V=$G(^TMP( "GMRCR",$J ,"RES",GMR CR0,"ADD", GMRCADD,GM RCV))
	272	.;
	273	. F GMRCV ="GMRCCSDT ","GMRCCTI T","GMRCCS GM","GMRCC SIG" D
	274	.. S @GMR CV=$G(^TMP ("GMRCR",$ J,"RES",GM RCR0,"ADD" ,GMRCADD,G MRCV))
	275	.S GMRCND X=$O(^TMP( "GMRC",$J, "OUTPUT"," RES"," "), -1)+1
	276	.I $L($G( GMRCRPT)) D SUB("H", "RES",GMRC NDX,"Adden dum #"_GMR CADD_" To Consult No te #"_GMRC R0_" for " _GMRCRPT_" continued .")
	277	.I '$L($G (GMRCRPT)) D SUB("H" ,"RES",GMR CNDX,"Adde ndum #"_GM RCADD_" To Consult N ote #"_GMR CR0_" cont inued.")
	278	.D SUB("H ","RES",GM RCNDX," ")
	279	.I $L($G( GMRCSGNM)) D
	280	..D SUB(" F","RES",G MRCNDX," " )
	281	..I (GMRC MODE="elec tronic") S GMRCX=" A ddendum Si gnature: " _GMRCSGNM_ " /es/ "_$ $EXDT($G(G MRCNMDT))
	282	..I '(GMR CMODE="ele ctronic") S GMRCX=" Addendum A uthor: "_G MRCSGNM S: $L($G(GMRC NMDT)) GMR CX=GMRCX_" Last edit ed: "_$$EX DT(GMRCNMD T)
	283	..D SUB(" F","RES",G MRCNDX,GMR CX)
	284	..D:$L($G (GMRCTIT)) SUB("F"," RES",GMRCN DX," "_GMR CTIT)
	285	.I $L($G( GMRCCSDT)) D
	286	..D SUB(" F","RES",G MRCNDX," " )
	287	..I (GMRC CSGM="elec tronic") S GMRCX=" A ddendum Co Signature: "_GMRCCSI G_" /es/ " _$$EXDT(GM RCCSDT)
	288	..I '(GMR CCSGM="ele ctronic") S GMRCX=" Addendum C oSignature : "_GMRCCS IG_" /char t/ "_$$EXD T(GMRCCSDT )
	289	..D SUB(" F","RES",G MRCNDX,GMR CX)
	290	..D:$L($G (GMRCCTIT) ) SUB("F", "RES",GMRC NDX," "_ GMRCCTIT)
	291	.D BLD("R ES",GMRCND X,1,0," ")
	292	.I $L($G( GMRCRPT)) D BLD("RES ",GMRCNDX, 1,0,$$CENT ER("ADDEND UM #"_GMRC ADD_" TO C ONSULT NOT E #"_GMRCR 0_" FOR "_ GMRCRPT))
	293	.I '$L($G (GMRCRPT)) D BLD("RE S",GMRCNDX ,1,0,$$CEN TER("ADDEN DUM #"_GMR CADD_" TO CONSULT NO TE #"_GMRC R0))
	294	.D BLD("R ES",GMRCND X,1,0," ")
	295	.S GMRCR1 =0 F S GM RCR1=$O(^T MP("GMRCR" ,$J,"RES", GMRCR0,"AD D",GMRCADD ,GMRCR1)) Q:'GMRCR1 D
	296	..D BLD(" RES",GMRCN DX,1,0,$G( ^TMP("GMRC R",$J,"RES ",GMRCR0," ADD",GMRCA DD,GMRCR1, 0)))
	297	Q
	298	;
	299	HDR ; Head er code fo r form 513
	300	;GMRCPEL ext fmt Primary El igibiity C ode
	301	;GMRCELIG ext fmt of Patient Type defi ned @ FORM AT^GMRCP5A
	302	;CVELIG marker t o indicate if pt has active pr eference f or Combat Veteran El igibility status
	303	;get and format eli gibility i nfo
	304	N VAEL,VA PA,GMRCPEL ,SUB,GMRCF ROM
	305	N CVELIG ;WAT
	306	D ELIG^VA DPT
	307	D ADD^VAD PT
	308	N VASV,OE FOIF D SVC ^VADPT S:( VASV(11)>0 )!(VASV(12 )>0)!(VASV (13)>0) OE FOIF="OEF/ OIF" ;WAT 66
	309	S GMRCPEL =$P(VAEL(1 ),U,2)
	310	I $L($G(G MRCELIG)) D
	311	.;if TYPE is Active Duty and VETERAN Y/ N? is No, then call the pt Act ive Duty
	312	.S:$P(VAE L(6),U,1)= 5&(VAEL(4) =0) GMRCEL IG=$P(VAEL (6),U,2)
	313	F SUB=0,1 D
	314	.N GMRCFL N
	315	.S GMRCFL N=$P($G(^D PT(GMRCDFN ,0)),U,1)
	316	.S CVELIG =$$CVEDT^D GCV(GMRCDF N) S:$P($G (CVELIG),U ,3) CVELIG ="CV ELIGI BLE" ;WAT
	317	.D BLD("H DR",SUB,1, 0,GMRCDVL)
	318	.D BLD("H DR",SUB,1, 6,"MEDICAL RECORD")
	319	.D BLD("H DR",SUB,0, 39,"\|")
	320	.D BLD("H DR",SUB,0, 45,"CONSUL TATION SHE ET")
	321	.D BLD("H DR",SUB,1, 0,GMRCDVL)
	322	.D BLD("H DR",SUB,1, 0,GMRCFLN)
	323	.D BLD("H DR",SUB,0, 45,GMRCPEL )
	324	.D BLD("H DR",SUB,1, 0,"XXX-XX- "_$P(GMRCS N,"-",3))
	325	.D BLD("H DR",SUB,0, 16,$$EXDT( GMRCDOB))
	326	.D BLD("H DR",SUB,0, 45,GMRCELI G)
	327	.D:$G(CVE LIG)["CV" BLD("HDR", SUB,1,45,C VELIG)
	328	.D:$G(OEF OIF)="OEF/ OIF" BLD(" HDR",SUB,1 ,45,OEFOIF ) ;WAT 66
	329	;
	330	; ADDR ESS LINES 1-3
	331	F GMRCX=1 ,2,3 D:$L( VAPA(GMRCX ))
	332	.D BLD("H DR",0,1,0, VAPA(GMRCX ))
	333	.;I GMRCX =1 D BLD(" HDR",0,0,5 1,"Standar d Form 513 (Rev 9-77 )")
	334	;
	335	; CITY S TATE ZIP CODE
	336	S GMRCX=V APA(4)_" "_$P(VAPA (5),U,2)_" "_VA PA(6)
	337	;
	338	I $L(VAPA (8)) S GMR CX=GMRCX_" Phon e: "_VAPA( 8) ; TEL EPHONE (IF AVAILABLE )
	339	;
	340	D BLD("HD R",0,1,0,G MRCX)
	341	D BLD("HD R",0,1,0,G MRCDVL)
	342	D BLD("HD R",0,1,0," Consult Re quest: "_$ $CONSRQ(GM RCIFN))
	343	D BLD("HD R",0,1,55, "\|Consult No.: "_GMR CIFN)
	344	;
	345	D BLD("HD R",1,1,0,G MRCEQL)
	346	D BLD("HD R",0,1,0,G MRCDVL)
	347	;
	348	I $G(CMT) D BLD("HD R",0,1,27, "("_$$PRCM T^GMRCP5B( CMT)_")") Q
	349	;
	350	S GMRCFRO M=$P($G(^S C(+$P(GMRC RD,U,6),0) ),U,1)
	351	;
	352	I '$L(GMR CFROM) D
	353	.N VAIN
	354	.D INP^VA DPT
	355	.S GMRCFR OM=$P($G(V AIN(4)),U, 2)
	356	.I $L($G( VAIN(5))) S GMRCFROM =GMRCFROM_ " (Rm/Bd: "_$G(VAIN( 5))_" )"
	357	;No locat ion, IFC - consultin g site
	358	I '$L(GMR CFROM),$P( GMRCRD,U,2 3),$P($G(G MRCRD(12)) ,U,5)="F" D
	359	.I $P(GMR CRD,U,21) S GMRCFROM =$$GET1^DI Q(4,$P(GMR CRD,U,21), .01)
	360	.E S GMR CFROM=$$GE T1^DIQ(4,$ P(GMRCRD,U ,23),.01)
	361	;
	362	D BLD("HD R",0,1,0," To: "_$P($ G(^GMR(123 .5,+$P(GMR CRD,U,5),0 )),U,1))
	363	D BLD("HD R",0,1,5," From: "_GM RCFROM)
	364	D BLD("HD R",0,0,49, "\|Requeste d: "_$$EXD T($P(GMRCR D,U,7)))
	365	;
	366	D BLD("HD R",0,1,0,G MRCDVL)
	367	D BLD("HD R",0,1,0," Requesting Facility: "_$E(GMRC FAC,1,22))
	368	I $P(GMRC RD,U,11) D BLD("HDR" ,0,0,45,"\| ATTENTION: "_$E($$GE T1^DIQ(200 ,+$P(GMRCR D,U,11),.0 1),1,21))
	369	I $P(GMRC RD,U,23) D
	370	. D BLD(" HDR",0,1,0 ,"Remote C onsult No. : "_GMRCIN O)
	371	. D BLD(" HDR",0,1,0 ,"Role: "_ GMRCIRL)
	372	D BLD("HD R",0,1,0,G MRCEQL)
	373	;
	374	D KVAR^VA DPT ;WAT 6 6
	375	Q
	376	;
	377	CENTER(X) ;
	378	;
	379	N TEXT,CO L
	380	S COL=35- ($L(X)\2) Q:(COL<1) X
	381	S $E(TEXT ,COL)=X
	382	Q TEXT
	383	;
	384	BLD(SUB,ND X,LINE,TAB ,TEXT,RUNT IME) ;
	385	;
	386	Q:'$L($G( SUB))
	387	N LINECNT
	388	;
	389	F LINECNT =1:1:+LINE S ^TMP("G MRC",$J,"O UTPUT",SUB ,NDX,$$LAS TLN(SUB,ND X)+1,0)=""
	390	;
	391	S $E(^TMP ("GMRC",$J ,"OUTPUT", SUB,NDX,$$ LASTLN(SUB ,NDX),0),T AB+1)=TEXT
	392	I $L($G(R UNTIME)) S ^TMP("GMR C",$J,"OUT PUT",SUB,N DX,$$LASTL N(SUB,NDX) ,1)=RUNTIM E
	393	;
	394	S GMRCLAS T=SUB
	395	Q
	396	;
	397	SUB(ZONE,S UB,NDX,TEX T) ;
	398	;
	399	N NEXT
	400	S NEXT=$O (^TMP("GMR C",$J,"OUT PUT",SUB,N DX,ZONE," "),-1)+1
	401	S ^TMP("G MRC",$J,"O UTPUT",SUB ,NDX,ZONE, NEXT,0)=TE XT
	402	Q
	403	;
	404	LASTLN(SUB ,NDX) ;
	405	Q +$O(^TM P("GMRC",$ J,"OUTPUT" ,SUB,NDX," "),-1)
	406	;
	407	CONSRQ(IFN ) ;
	408	;
	409	N PTR,LIN K,REF,GMRC RQ
	410	I +$P(^GM R(123,+IFN ,0),U,8) D
	411	. S GMRCR Q=$P(^GMR( 123,+IFN,0 ),U,8)
	412	. S GMRCR Q=$$GET1^D IQ(123.3,+ GMRCRQ,.01 )
	413	. I '$L(G MRCRQ) S G MRCRQ="Pro cedure"
	414	I $L($G(G MRCRQ)) Q GMRCRQ
	415	I $L($G(^ GMR(123,IF N,1.11))) D
	416	. N SERV, TYPE
	417	. S SERV= $$UP^XLFST R($$GET1^D IQ(123.5,$ P(^GMR(123 ,IFN,0),U, 5),.01))
	418	. S TYPE= $$UP^XLFST R(^GMR(123 ,IFN,1.11) ) I TYPE'= SERV D
	419	. I TYPE' =SERV S GM RCRQ=$E(^G MR(123,IFN ,1.11),1,3 6)
	420	Q:$L($G(G MRCRQ)) GM RCRQ Q "Co nsult"
	421	;
	422	EXDT(X) ;E XTERNAL DA TE FORMAT
	423	;
	424	N DATE,TI ME,HR,MN,P D,Y,%DT
	425	Q:'$L(X) ""
	426	I '(X?7N. 1".".6N) S %DT="PTS" D ^%DT S X=Y
	427	Q $$FMTE^ XLFDT(X,"5 PMZ")
	428	;
	429	After:
	430	GMRCP5D ;S LC/DCM,RJS ,JFR,WAT,D EH - Print Consult f orm 513 (G ather Data - Addendu ms, Header s, Service reports a nd Comment s) ;01/20/ 17 15:19
	431	;;3.0;CON SULT/REQUE ST TRACKIN G;4,12,1 5,22,29,35 ,38,61,65, 66,82,89 ;Dec 27, 1 997;Build 11
	432	;Waiver # 301965 sub mitted 201 4.02.02,pe nding as o f 2015.05. 05/JDT
	433	; MILW/RH /JDT 9/09 HDR+26,+27 concanten ated age t o DOB
	434	; MILW/JD T HDR+41 a dd cell ph one to hea der
	435	; WLE add ed Cell ph one and ag e to SF513
	436	;This rou tine invok es the fol lowing ICR (s):
	437	;2056 $$G ET1^DIQ, 2 541 $$KSP^ XUPARAM, 1 0103 $$FMT E^XLFDT, 1 0104 $$UP^ XLFSTR, 10 061 VADPT API
	438	;10040 ^S C(, 4156 $ $CVEDT^DGC V
	439	;
	440	FORMAT(GMR CIFN,GMRCR D,PAGEWID) ;
	441	;
	442	I $L($P(G MRCRD,U,15 )) D
	443	.I $O(^TM P("GMRCR", $J,"MCAR", 0)) D
	444	..N GMRCS VC
	445	..S GMRCS VC=$P($G(^ GMR(123.5, +$P(GMRCRD ,U,5),0)), U,1)
	446	..S:$L(GM RCSVC) GMR CSVC=GMRCS VC_" "
	447	..;
	448	..; Medic ine Result s?
	449	..S GMRCR 0=0 F S G MRCR0=$O(^ TMP("GMRCR ",$J,"MCAR ",GMRCR0)) Q:'GMRCR0 D
	450	...D SUB( "H","SREP" ,GMRCR0,$$ CENTER(GMR CSVC_"Serv ice Report #"_GMRCR0 _" continu ed."))
	451	...D SUB( "H","SREP" ,GMRCR0," ")
	452	...D BLD( "SREP",GMR CR0,1,0,$$ CENTER("Me dicine Pac kage Repor t"))
	453	...D BLD( "SREP",GMR CR0,1,0,"" )
	454	...N LN
	455	...S LN=0 F S LN=$ O(^TMP("GM RCR",$J,"M CAR",GMRCR 0,LN)) Q:' LN D
	456	....D BLD ("SREP",GM RCR0,1,0,$ G(^TMP("GM RCR",$J,"M CAR",GMRCR 0,LN,0)))
	457	;
	458	; Build P rocessing Activities
	459	S GMRCR0= 0 F S GMR CR0=$O(^GM R(123,GMRC IFN,40,GMR CR0)) Q:'G MRCR0 D
	460	.N GMRCR1 ,GMRC400,C MT,USER,GM RCDT,RPRV, GMRC402,GM RCISIT
	461	.S GMRCR1 =+$O(^GMR( 123,GMRCIF N,40,GMRCR 0,0)) Q:GM RCR1'=1
	462	.S GMRC40 0=$G(^GMR( 123,GMRCIF N,40,GMRCR 0,0))
	463	.S GMRC40 2=$G(^GMR( 123,GMRCIF N,40,GMRCR 0,2))
	464	.S CMT=$$ PRCMT^GMRC P5B(+$P(GM RC400,U,2) ) Q:'$L(CM T)
	465	.S GMRCDT =$P(GMRC40 0,U,3) S:' GMRCDT GMR CDT=$P(GMR C400,U,1)
	466	.S GMRCDT =$$EXDT(GM RCDT)_" "_ $P(GMRC402 ,U,3)
	467	.;Followi ng lines m odified in patch *38
	468	.;I $P(^G MR(123,GMR CIFN,0),U, 23) D ;co mmented ou t
	469	.;.S GMRC ISIT=$$GET 1^DIQ(4,$P (^GMR(123, GMRCIFN,0) ,U,23),.01 ) ;commen ted out
	470	.;.S GMRC ISIT="Ente red at: "_ GMRCISIT ;commented out
	471	.I $L(GMR C402) D ; ADDED
	472	..S GMRCI SIT=$$GET1 ^DIQ(123,G MRCIFN,.07 ) ;ADDED
	473	.I '$D(GM RCISIT) D ;ADDED
	474	..S GMRCI SIT=$$KSP^ XUPARAM("I NST") ;AD DED
	475	..I GMRCI SIT'="" S GMRCISIT=$ $GET1^DIQ( 4,GMRCISIT ,.01) ;AD DED
	476	..I GMRCI SIT="" S G MRCISIT=$$ GET1^DIQ(1 23,GMRCIFN ,.05) ;AD DED
	477	.S GMRCIS IT="Entere d at: "_GM RCISIT ;A DDED
	478	.;End of modificati ons for pa tch *38
	479	.S RPRV=$ $GET1^DIQ( 200,+$P(GM RC400,U,4) ,.01)
	480	.I '$L(RP RV) S RPRV =$P(GMRC40 2,U,2)
	481	.S:($L(RP RV)) RPRV= "Responsib le Person: "_RPRV
	482	.S USER=$ $GET1^DIQ( 200,+$P(GM RC400,U,5) ,.01)
	483	.I '$L(US ER) S USER =$P(GMRC40 2,U)
	484	.S USER=" Entered by : "_USER_" - "_GMRCD T
	485	.D SUB("H ","COM",GM RCR0,CMT_" Comment ( "_USER_") continued. ")
	486	.D SUB("H ","COM",GM RCR0," ")
	487	.D BLD("C OM",GMRCR0 ,1,0,"")
	488	.D BLD("C OM",GMRCR0 ,1,0,$$CEN TER("("_CM T_" Commen t)"))
	489	.I $P(GMR C400,U,2)= 17!($P(GMR C400,U,2)= 25) D
	490	.. N FWDL N,FWDRS
	491	.. S FWDL N="Forward ed from: "
	492	.. S FWDR S=$P($G(^G MR(123,GMR CIFN,40,GM RCR0,3)),U )
	493	.. I $L(F WDRS) S FW DLN=FWDLN_ FWDRS
	494	.. I '$L( FWDRS) S F WDLN=FWDLN _$$GET1^DI Q(123.5,+$ P(GMRC400, U,6),.01)
	495	.. D BLD( "COM",GMRC R0,1,5,FWD LN)
	496	.D BLD("C OM",GMRCR0 ,1,5,USER)
	497	.D:($L(RP RV)) BLD(" COM",GMRCR 0,1,5,RPRV )
	498	.D:($L($G (GMRCISIT) )) BLD("CO M",GMRCR0, 1,5,GMRCIS IT)
	499	.;
	500	.N GMRCR2 S GMRCR2= 0
	501	.F S GMR CR2=$O(^GM R(123,GMRC IFN,40,GMR CR0,GMRCR1 ,GMRCR2)) Q:'GMRCR2 D
	502	..D BLD(" COM",GMRCR 0,1,0,$G(^ GMR(123,GM RCIFN,40,G MRCR0,GMRC R1,GMRCR2, 0)))
	503	;
	504	Q
	505	;
	506	ADDEND(GMR CIFN,GMRCR 0,GMRCNDX, GMRCRD,PAG EWID) ;
	507	;
	508	N GMRCADD ,GMRCNDX,G MRCR1,GMRC V,TEXT,GMR CX
	509	;
	510	S GMRCADD =0 F S GM RCADD=$O(^ TMP("GMRCR ",$J,"RES" ,GMRCR0,"A DD",GMRCAD D)) Q:'GMR CADD D
	511	.N GMRCSG NM,GMRCNMD T,GMRCTIT, GMRCMODE,G MRCCSDT,GM RCCTIT,GMR CCSGM
	512	.;
	513	.F GMRCV= "GMRCSGNM" ,"GMRCNMDT ","GMRCTIT ","GMRCMOD E" D
	514	..S @GMRC V=$G(^TMP( "GMRCR",$J ,"RES",GMR CR0,"ADD", GMRCADD,GM RCV))
	515	.;
	516	. F GMRCV ="GMRCCSDT ","GMRCCTI T","GMRCCS GM","GMRCC SIG" D
	517	.. S @GMR CV=$G(^TMP ("GMRCR",$ J,"RES",GM RCR0,"ADD" ,GMRCADD,G MRCV))
	518	.S GMRCND X=$O(^TMP( "GMRC",$J, "OUTPUT"," RES"," "), -1)+1
	519	.I $L($G( GMRCRPT)) D SUB("H", "RES",GMRC NDX,"Adden dum #"_GMR CADD_" To Consult No te #"_GMRC R0_" for " _GMRCRPT_" continued .")
	520	.I '$L($G (GMRCRPT)) D SUB("H" ,"RES",GMR CNDX,"Adde ndum #"_GM RCADD_" To Consult N ote #"_GMR CR0_" cont inued.")
	521	.D SUB("H ","RES",GM RCNDX," ")
	522	.I $L($G( GMRCSGNM)) D
	523	..D SUB(" F","RES",G MRCNDX," " )
	524	..I (GMRC MODE="elec tronic") S GMRCX=" A ddendum Si gnature: " _GMRCSGNM_ " /es/ "_$ $EXDT($G(G MRCNMDT))
	525	..I '(GMR CMODE="ele ctronic") S GMRCX=" Addendum A uthor: "_G MRCSGNM S: $L($G(GMRC NMDT)) GMR CX=GMRCX_" Last edit ed: "_$$EX DT(GMRCNMD T)
	526	..D SUB(" F","RES",G MRCNDX,GMR CX)
	527	..D:$L($G (GMRCTIT)) SUB("F"," RES",GMRCN DX," "_GMR CTIT)
	528	.I $L($G( GMRCCSDT)) D
	529	..D SUB(" F","RES",G MRCNDX," " )
	530	..I (GMRC CSGM="elec tronic") S GMRCX=" A ddendum Co Signature: "_GMRCCSI G_" /es/ " _$$EXDT(GM RCCSDT)
	531	..I '(GMR CCSGM="ele ctronic") S GMRCX=" Addendum C oSignature : "_GMRCCS IG_" /char t/ "_$$EXD T(GMRCCSDT )
	532	..D SUB(" F","RES",G MRCNDX,GMR CX)
	533	..D:$L($G (GMRCCTIT) ) SUB("F", "RES",GMRC NDX," "_ GMRCCTIT)
	534	.D BLD("R ES",GMRCND X,1,0," ")
	535	.I $L($G( GMRCRPT)) D BLD("RES ",GMRCNDX, 1,0,$$CENT ER("ADDEND UM #"_GMRC ADD_" TO C ONSULT NOT E #"_GMRCR 0_" FOR "_ GMRCRPT))
	536	.I '$L($G (GMRCRPT)) D BLD("RE S",GMRCNDX ,1,0,$$CEN TER("ADDEN DUM #"_GMR CADD_" TO CONSULT NO TE #"_GMRC R0))
	537	.D BLD("R ES",GMRCND X,1,0," ")
	538	.S GMRCR1 =0 F S GM RCR1=$O(^T MP("GMRCR" ,$J,"RES", GMRCR0,"AD D",GMRCADD ,GMRCR1)) Q:'GMRCR1 D
	539	..D BLD(" RES",GMRCN DX,1,0,$G( ^TMP("GMRC R",$J,"RES ",GMRCR0," ADD",GMRCA DD,GMRCR1, 0)))
	540	Q
	541	;
	542	HDR ; Head er code fo r form 513
	543	;GMRCPEL ext fmt Primary El igibiity C ode
	544	;GMRCELIG ext fmt of Patient Type defi ned @ FORM AT^GMRCP5A
	545	;CVELIG marker t o indicate if pt has active pr eference f or Combat Veteran El igibility status
	546	;get and format eli gibility i nfo
	547	N VAEL,VA PA,GMRCPEL ,SUB,GMRCF ROM
	548	N CVELIG ;WAT
	549	D ELIG^VA DPT
	550	D ADD^VAD PT
	551	N VASV,OE FOIF D SVC ^VADPT S:( VASV(11)>0 )!(VASV(12 )>0)!(VASV (13)>0) OE FOIF="OEF/ OIF" ;WAT 66
	552	S GMRCPEL =$P(VAEL(1 ),U,2)
	553	I $L($G(G MRCELIG)) D
	554	.;if TYPE is Active Duty and VETERAN Y/ N? is No, then call the pt Act ive Duty
	555	.S:$P(VAE L(6),U,1)= 5&(VAEL(4) =0) GMRCEL IG=$P(VAEL (6),U,2)
	556	F SUB=0,1 D
	557	.N GMRCFL N
	558	.S GMRCFL N=$P($G(^D PT(GMRCDFN ,0)),U,1)
	559	.S CVELIG =$$CVEDT^D GCV(GMRCDF N) S:$P($G (CVELIG),U ,3) CVELIG ="CV ELIGI BLE" ;WAT
	560	.D BLD("H DR",SUB,1, 0,GMRCDVL)
	561	.D BLD("H DR",SUB,1, 6,"MEDICAL RECORD")
	562	.D BLD("H DR",SUB,0, 39,"\|")
	563	.D BLD("H DR",SUB,0, 45,"CONSUL TATION SHE ET")
	564	.D BLD("H DR",SUB,1, 0,GMRCDVL)
	565	.D BLD("H DR",SUB,1, 0,GMRCFLN)
	566	.D BLD("H DR",SUB,0, 45,GMRCPEL )
	567	.D BLD("H DR",SUB,1, 0,"XXX-XX- "_$P(GMRCS N,"-",3))
	568	.D BLD("H DR",SUB,0, 16,$$EXDT( GMRCDOB)_" (Age: "_G MRCAGE_")" ) ;89 add age
	569	.D BLD("H DR",SUB,0, 45,GMRCELI G)
	570	.D:$G(CVE LIG)["CV" BLD("HDR", SUB,1,45,C VELIG)
	571	.D:$G(OEF OIF)="OEF/ OIF" BLD(" HDR",SUB,1 ,45,OEFOIF ) ;WAT 66
	572	;
	573	; ADDR ESS LINES 1-3
	574	F GMRCX=1 ,2,3 D:$L( VAPA(GMRCX ))
	575	.D BLD("H DR",0,1,0, VAPA(GMRCX ))
	576	.;I GMRCX =1 D BLD(" HDR",0,0,5 1,"Standar d Form 513 (Rev 9-77 )")
	577	;
	578	; CITY S TATE ZIP CODE
	579	S GMRCX=V APA(4)_" "_$P(VAPA (5),U,2)_" "_VA PA(6)
	580	;
	581	I $L(VAPA (8)) S GMR CX=GMRCX_" Phone: "_ VAPA(8) ; TELEPHONE (IF AVAILA BLE)
	582	I $L($P($ G(^DPT(GMR CDFN,.13)) ,U,4)) S G MRCX=GMRCX _" Cell: " _$P($G(^DP T(GMRCDFN, .13)),U,4) ;89 add c ell phone.
	583	;
	584	D BLD("HD R",0,1,0,G MRCX)
	585	D BLD("HD R",0,1,0,G MRCDVL)
	586	D BLD("HD R",0,1,0," Consult Re quest: "_$ $CONSRQ(GM RCIFN))
	587	D BLD("HD R",0,1,55, "\|Consult No.: "_GMR CIFN)
	588	;
	589	D BLD("HD R",1,1,0,G MRCEQL)
	590	D BLD("HD R",0,1,0,G MRCDVL)
	591	;
	592	I $G(CMT) D BLD("HD R",0,1,27, "("_$$PRCM T^GMRCP5B( CMT)_")") Q
	593	;
	594	S GMRCFRO M=$P($G(^S C(+$P(GMRC RD,U,6),0) ),U,1)
	595	;
	596	I '$L(GMR CFROM) D
	597	.N VAIN
	598	.D INP^VA DPT
	599	.S GMRCFR OM=$P($G(V AIN(4)),U, 2)
	600	.I $L($G( VAIN(5))) S GMRCFROM =GMRCFROM_ " (Rm/Bd: "_$G(VAIN( 5))_" )"
	601	;No locat ion, IFC - consultin g site
	602	I '$L(GMR CFROM),$P( GMRCRD,U,2 3),$P($G(G MRCRD(12)) ,U,5)="F" D
	603	.I $P(GMR CRD,U,21) S GMRCFROM =$$GET1^DI Q(4,$P(GMR CRD,U,21), .01)
	604	.E S GMR CFROM=$$GE T1^DIQ(4,$ P(GMRCRD,U ,23),.01)
	605	;
	606	D BLD("HD R",0,1,0," To: "_$P($ G(^GMR(123 .5,+$P(GMR CRD,U,5),0 )),U,1))
	607	D BLD("HD R",0,1,5," From: "_GM RCFROM)
	608	D BLD("HD R",0,0,49, "\|Requeste d: "_$$EXD T($P(GMRCR D,U,7)))
	609	;
	610	D BLD("HD R",0,1,0,G MRCDVL)
	611	D BLD("HD R",0,1,0," Requesting Facility: "_$E(GMRC FAC,1,22))
	612	I $P(GMRC RD,U,11) D BLD("HDR" ,0,0,45,"\| ATTENTION: "_$E($$GE T1^DIQ(200 ,+$P(GMRCR D,U,11),.0 1),1,21))
	613	I $P(GMRC RD,U,23) D
	614	. D BLD(" HDR",0,1,0 ,"Remote C onsult No. : "_GMRCIN O)
	615	. D BLD(" HDR",0,1,0 ,"Role: "_ GMRCIRL)
	616	D BLD("HD R",0,1,0,G MRCEQL)
	617	;
	618	D KVAR^VA DPT ;WAT 6 6
	619	Q
	620	;
	621	CENTER(X) ;
	622	;
	623	N TEXT,CO L
	624	S COL=35- ($L(X)\2) Q:(COL<1) X
	625	S $E(TEXT ,COL)=X
	626	Q TEXT
	627	;
	628	BLD(SUB,ND X,LINE,TAB ,TEXT,RUNT IME) ;
	629	;
	630	Q:'$L($G( SUB))
	631	N LINECNT
	632	;
	633	F LINECNT =1:1:+LINE S ^TMP("G MRC",$J,"O UTPUT",SUB ,NDX,$$LAS TLN(SUB,ND X)+1,0)=""
	634	;
	635	S $E(^TMP ("GMRC",$J ,"OUTPUT", SUB,NDX,$$ LASTLN(SUB ,NDX),0),T AB+1)=TEXT
	636	I $L($G(R UNTIME)) S ^TMP("GMR C",$J,"OUT PUT",SUB,N DX,$$LASTL N(SUB,NDX) ,1)=RUNTIM E
	637	;
	638	S GMRCLAS T=SUB
	639	Q
	640	;
	641	SUB(ZONE,S UB,NDX,TEX T) ;
	642	;
	643	N NEXT
	644	S NEXT=$O (^TMP("GMR C",$J,"OUT PUT",SUB,N DX,ZONE," "),-1)+1
	645	S ^TMP("G MRC",$J,"O UTPUT",SUB ,NDX,ZONE, NEXT,0)=TE XT
	646	Q
	647	;
	648	LASTLN(SUB ,NDX) ;
	649	Q +$O(^TM P("GMRC",$ J,"OUTPUT" ,SUB,NDX," "),-1)
	650	;
	651	CONSRQ(IFN ) ;
	652	;
	653	N PTR,LIN K,REF,GMRC RQ
	654	I +$P(^GM R(123,+IFN ,0),U,8) D
	655	. S GMRCR Q=$P(^GMR( 123,+IFN,0 ),U,8)
	656	. S GMRCR Q=$$GET1^D IQ(123.3,+ GMRCRQ,.01 )
	657	. I '$L(G MRCRQ) S G MRCRQ="Pro cedure"
	658	I $L($G(G MRCRQ)) Q GMRCRQ
	659	I $L($G(^ GMR(123,IF N,1.11))) D
	660	. N SERV, TYPE
	661	. S SERV= $$UP^XLFST R($$GET1^D IQ(123.5,$ P(^GMR(123 ,IFN,0),U, 5),.01))
	662	. S TYPE= $$UP^XLFST R(^GMR(123 ,IFN,1.11) ) I TYPE'= SERV D
	663	. I TYPE' =SERV S GM RCRQ=$E(^G MR(123,IFN ,1.11),1,3 6)
	664	Q:$L($G(G MRCRQ)) GM RCRQ Q "Co nsult"
	665	;
	666	EXDT(X) ;E XTERNAL DA TE FORMAT
	667	;
	668	N DATE,TI ME,HR,MN,P D,Y,%DT
	669	Q:'$L(X) ""
	670	I '(X?7N. 1".".6N) S %DT="PTS" D ^%DT S X=Y
	671	Q $$FMTE^ XLFDT(X,"5 PMZ")
	672	;
	673	GMRCUTL1
	674	Before:
	675	GMRCUTL1 ; SLC/DCM,JF R,MA - Gen eral Utili ties ;10/1 5/02 11:4 9
	676	;;3.0;CON SULT/REQUE ST TRACKIN G;1,4,12 ,15,21,17, 28;DEC 2 7, 1997
	677	;
	678	; This ro utine invo kes IA #28 76,3121
	679	; Patch # 21 added v ariable GM RCAUDT and moved lin e tag PRNT AUDT
	680	; to GMRC P5A.
	681	;
	682	ACTM ;;Set correct v ariables t o complete , disconti nue, etc. a consult
	683	K GMRCQUT
	684	S:'+$G(GM RCA) GMRCA =$O(^GMR(1 23.1,"B",G MRCACTM,"" ))
	685	S GMRCACT M=$P($G(^G MR(123.1,+ GMRCA,0)), "^")
	686	S ORSTS=$ S(GMRCA:$P (^GMR(123. 1,GMRCA,0) ,"^",2),1: 0)
	687	I 'GMRCA S GMRCQUT= 1
	688	Q
	689	PRNT(SRVCI FN,GMRCO) ;print for m 513 to a printer w hen new co nsult is e ntered
	690	N ORVP,GM RCDEV,GMRC QUED,IOP,% ZIS,POP,ZT DTH,ZTDESC ,ZTIO,ZTRT N,ZTSK,GMR CAUDT
	691	I '$G(SRV CIFN) S SR VCIFN=+$P( ^GMR(123,G MRCO,0),U, 5)
	692	Q:'$D(^GM R(123.5,SR VCIFN,123) ) Q:'$P(^ GMR(123.5, SRVCIFN,12 3),"^",9)
	693	S IOP="`" _$P(^GMR(1 23.5,SRVCI FN,123),"^ ",9)
	694	S %ZIS="N " D ^%ZIS I POP S %Z IS=0 D HOM E^%ZIS Q
	695	S GMRCDEV =ION,GMRCQ UED=1,GMRC AUDT=1
	696	S ZTRTN=" PRNT^GMRCP 5A("_(+GMR CO)_","_(+ $G(TIUFLG) )_",1,"""_ $G(GMRCCPY ,"W")_""", 0,"_(GMRCA UDT)_")"
	697	S ZTDESC= "CONSULT/R EQUEST PAC KAGE PRINT FORM 513 FOR NEW CO NSULT"
	698	S ZTIO=GM RCDEV,ZTDT H=$H
	699	D ^%ZTLOA D
	700	S %ZIS=0 D HOME^%ZI S
	701	K GMRCQUE D,GMRCDEV1
	702	Q
	703	END K GMRC DEV,GMRCDE V1,GMRCORE C,GMRCFMT
	704	Q
	705	PROVDX(OI) ;return P ROV DX pro mpting inf o from 123 .5
	706	; Inpu t:
	707	; O I = ref to file 123. 5("#;99CON ") or file 123.3 (#; 99PRC)
	708	;
	709	; Retu rns: stri ng A^B
	710	; A = O (opti onal), R ( required) or S (supp ress)
	711	; B = F (free -text) or L (lexicon )
	712	;
	713	N GMRCFIL
	714	Q:'+$G(OI ) "^"
	715	S GMRCFIL =$S(OI["99 PRC":123.3 ,1:123.5)
	716	Q:'$D(^GM R(GMRCFIL, +OI)) "^"
	717	N STRING, NODE
	718	I GMRCFIL =123.3 S N ODE=$P(^GM R(123.3,+O I,0),U,7,8 )
	719	I GMRCFIL =123.5 S N ODE=$P($G( ^GMR(123.5 ,+OI,1)),U ,1,2)
	720	I NODE="" Q "O^F" ; values not set
	721	S $P(STRI NG,U)=$S($ L($P(NODE, U)):$P(NOD E,U),1:"O" )
	722	S $P(STRI NG,U,2)=$S ($L($P(NOD E,U,2)):$P (NODE,U,2) ,1:"F")
	723	Q STRING
	724	ORIFN(GMRC 123) ;retu rn ORIFN a ssociated with give record in ^GMR(123,
	725	; GMRC123 = ien of consult re cord in fi le 123
	726	Q $P($G(^ GMR(123,GM RC123,0)), U,3)
	727	GETDT(PROM PT,DEFAULT ) ;prompt and return FM date
	728	;Input:
	729	; PROMPT = text o f prompt - DIR("A") ( optional)
	730	; DEFAUL T = defaul t date to prompt - D IR("B") ( optional)
	731	;
	732	;Output:
	733	; FM date /time if s uccessfull y answered , "^" if e xit or tim eout
	734	N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
	735	S DIR(0)= "DA^::EPT"
	736	S DIR("?" )="Enter t he date/ti me the act ivity took place."
	737	S DIR("A" )=$S($D(PR OMPT):PROM PT_" ",1:" Actual Dat e/Time of Activity: ")
	738	S DIR("B" )=$S($D(DE FAULT):DEF AULT,1:"NO W")
	739	D ^DIR
	740	I $D(DUOU T)!($D(DTO UT)) S Y=" ^"
	741	Q Y
	742	;
	743	DCPRNT(IEN ,USER) ;re print SF-5 13 on DC?
	744	N SERV,RE PR
	745	S SERV=$P (^GMR(123, IEN,0),U,5 ) I 'SERV Q 0
	746	S REPR=$P ($G(^GMR(1 23.5,SERV, 1)),U,5)
	747	I 'REPR Q 1
	748	I REPR=2 Q 0
	749	I REPR=1, '$$VALID^G MRCAU(SERV ,IEN,USER) Q 1
	750	Q 0
	751	;
	752	PREREQ(GMR CARR,GMRCS RV,GMRCDFN ,UNRESOLV) ; return service pr e-requisit e
	753	; pre-req uisite sto red in 125 nodes in file 123.5 or 123.3
	754	; GMRCARR = array t o return c ontaining pre-requis ite
	755	; GMRCSRV = ref to file 123.5 (ien;99CO N) or 123. 3 (ien;99P RC)
	756	; GMRCDFN = patient identifie r if to re turn resol ved
	757	; UNRESOL V = 1 or 0 ; if UNRE SOLV=1 GMR CARR will be returne d unresolv ed
	758	Q:'+GMRCS RV
	759	N GMRCFIL
	760	S GMRCFIL =$S(GMRCSR V["99PRC": 123.3,1:12 3.5)
	761	Q:'$D(^GM R(GMRCFIL, +GMRCSRV,1 25))
	762	I '$D(GMR CDFN)!($G( UNRESOLV)) D Q
	763	. M @GMRC ARR=^GMR(G MRCFIL,+GM RCSRV,125)
	764	D BLRPLT^ TIUSRVD(,, GMRCDFN,,$ NA(^GMR(GM RCFIL,+GMR CSRV,125)) )
	765	I $D(^TMP ("TIUBOIL" ,$J)) M @G MRCARR=^TM P("TIUBOIL ",$J)
	766	K ^TMP("T IUBOIL",$J )
	767	Q
	768	;
	769	LOCKREC(GM RCDA) ;att empt to lo ck a consu lt record using orde r or recor d
	770	; Input:
	771	; GMRCD A = ien o f consult record fro m file 123
	772	;
	773	; Output:
	774	; 1 o r 0^reason can't be locked
	775	; 1 = succ essfully l ocked
	776	; 0 = coul dn't be lo cked
	777	N GMRCORD ,GMRCMSG
	778	S GMRCORD =$P($G(^GM R(123,GMRC DA,0)),U,3 )
	779	I $G(GMRC ORD) D ;a n order as sociated
	780	. S GMRCM SG=$$LOCK1 ^ORX2(GMRC ORD)
	781	. ; GMRCM SG=1 if lo cked or 0 if couldn 't be lock ed
	782	I $L($G(G MRCMSG)) Q GMRCMSG
	783	; no orde r = Inter- facility C onsult so lock consu lt record
	784	L +^GMR(1 23,GMRCDA) :5
	785	I '$T Q " 0^Another user is ed iting this record" ; couldn't lock it
	786	Q 1
	787	;
	788	UNLKREC(GM RCDA) ;unl ock a cons ult record
	789	; Input:
	790	; GMRCD A = ien o f consult record fro m file 123
	791	;
	792	N GMRCORD
	793	S GMRCORD =$P($G(^GM R(123,GMRC DA,0)),U,3 )
	794	I $G(GMRC ORD) D Q
	795	. D UNLK1 ^ORX2(GMRC ORD)
	796	L -^GMR(1 23,GMRCDA)
	797	Q
	798	After:
	799	GMRCUTL1 ; SLC/DCM,JF R,MA - Gen eral Utili ties ;01/2 0/2017 15 :23
	800	;;3.0;CON SULT/REQUE ST TRACKIN G;1,4,12 ,15,21,17, 28,89;DE C 27, 1997 ;Build 16
	801	;Added ca ll to GMRC ZUTL for s econdary p rinter
	802	; This ro utine invo kes IA #28 76,3121
	803	; Patch # 21 added v ariable GM RCAUDT and moved lin e tag PRNT AUDT
	804	; to GMRC P5A.
	805	;
	806	ACTM ;;Set correct v ariables t o complete , disconti nue, etc. a consult
	807	K GMRCQUT
	808	S:'+$G(GM RCA) GMRCA =$O(^GMR(1 23.1,"B",G MRCACTM,"" ))
	809	S GMRCACT M=$P($G(^G MR(123.1,+ GMRCA,0)), "^")
	810	S ORSTS=$ S(GMRCA:$P (^GMR(123. 1,GMRCA,0) ,"^",2),1: 0)
	811	I 'GMRCA S GMRCQUT= 1
	812	Q
	813	PRNT(SRVCI FN,GMRCO) ;print for m 513 to a printer w hen new co nsult is e ntered
	814	D PRNT^GM RCZUTL(SRV CIFN,GMRCO ) ;89 cal l for seco ndary copy
	815	N ORVP,GM RCDEV,GMRC QUED,IOP,% ZIS,POP,ZT DTH,ZTDESC ,ZTIO,ZTRT N,ZTSK,GMR CAUDT
	816	I '$G(SRV CIFN) S SR VCIFN=+$P( ^GMR(123,G MRCO,0),U, 5)
	817	Q:'$D(^GM R(123.5,SR VCIFN,123) ) Q:'$P(^ GMR(123.5, SRVCIFN,12 3),"^",9)
	818	S IOP="`" _$P(^GMR(1 23.5,SRVCI FN,123),"^ ",9)
	819	S %ZIS="N " D ^%ZIS I POP S %Z IS=0 D HOM E^%ZIS Q
	820	S GMRCDEV =ION,GMRCQ UED=1,GMRC AUDT=1
	821	S ZTRTN=" PRNT^GMRCP 5A("_(+GMR CO)_","_(+ $G(TIUFLG) )_",1,"""_ $G(GMRCCPY ,"W")_""", 0,"_(GMRCA UDT)_")"
	822	S ZTDESC= "CONSULT/R EQUEST PAC KAGE PRINT FORM 513 FOR NEW CO NSULT"
	823	S ZTIO=GM RCDEV,ZTDT H=$H
	824	D ^%ZTLOA D
	825	S %ZIS=0 D HOME^%ZI S
	826	K GMRCQUE D,GMRCDEV1
	827	Q
	828	END K GMRC DEV,GMRCDE V1,GMRCORE C,GMRCFMT
	829	Q
	830	PROVDX(OI) ;return P ROV DX pro mpting inf o from 123 .5
	831	; Inpu t:
	832	; O I = ref to file 123. 5("#;99CON ") or file 123.3 (#; 99PRC)
	833	;
	834	; Retu rns: stri ng A^B
	835	; A = O (opti onal), R ( required) or S (supp ress)
	836	; B = F (free -text) or L (lexicon )
	837	;
	838	N GMRCFIL
	839	Q:'+$G(OI ) "^"
	840	S GMRCFIL =$S(OI["99 PRC":123.3 ,1:123.5)
	841	Q:'$D(^GM R(GMRCFIL, +OI)) "^"
	842	N STRING, NODE
	843	I GMRCFIL =123.3 S N ODE=$P(^GM R(123.3,+O I,0),U,7,8 )
	844	I GMRCFIL =123.5 S N ODE=$P($G( ^GMR(123.5 ,+OI,1)),U ,1,2)
	845	I NODE="" Q "O^F" ; values not set
	846	S $P(STRI NG,U)=$S($ L($P(NODE, U)):$P(NOD E,U),1:"O" )
	847	S $P(STRI NG,U,2)=$S ($L($P(NOD E,U,2)):$P (NODE,U,2) ,1:"F")
	848	Q STRING
	849	ORIFN(GMRC 123) ;retu rn ORIFN a ssociated with give record in ^GMR(123,
	850	; GMRC123 = ien of consult re cord in fi le 123
	851	Q $P($G(^ GMR(123,GM RC123,0)), U,3)
	852	GETDT(PROM PT,DEFAULT ) ;prompt and return FM date
	853	;Input:
	854	; PROMPT = text o f prompt - DIR("A") ( optional)
	855	; DEFAUL T = defaul t date to prompt - D IR("B") ( optional)
	856	;
	857	;Output:
	858	; FM date /time if s uccessfull y answered , "^" if e xit or tim eout
	859	N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
	860	S DIR(0)= "DA^::EPT"
	861	S DIR("?" )="Enter t he date/ti me the act ivity took place."
	862	S DIR("A" )=$S($D(PR OMPT):PROM PT_" ",1:" Actual Dat e/Time of Activity: ")
	863	S DIR("B" )=$S($D(DE FAULT):DEF AULT,1:"NO W")
	864	D ^DIR
	865	I $D(DUOU T)!($D(DTO UT)) S Y=" ^"
	866	Q Y
	867	;
	868	DCPRNT(IEN ,USER) ;re print SF-5 13 on DC?
	869	N SERV,RE PR
	870	S SERV=$P (^GMR(123, IEN,0),U,5 ) I 'SERV Q 0
	871	S REPR=$P ($G(^GMR(1 23.5,SERV, 1)),U,5)
	872	I 'REPR Q 1
	873	I REPR=2 Q 0
	874	I REPR=1, '$$VALID^G MRCAU(SERV ,IEN,USER) Q 1
	875	Q 0
	876	;
	877	PREREQ(GMR CARR,GMRCS RV,GMRCDFN ,UNRESOLV) ; return service pr e-requisit e
	878	; pre-req uisite sto red in 125 nodes in file 123.5 or 123.3
	879	; GMRCARR = array t o return c ontaining pre-requis ite
	880	; GMRCSRV = ref to file 123.5 (ien;99CO N) or 123. 3 (ien;99P RC)
	881	; GMRCDFN = patient identifie r if to re turn resol ved
	882	; UNRESOL V = 1 or 0 ; if UNRE SOLV=1 GMR CARR will be returne d unresolv ed
	883	Q:'+GMRCS RV
	884	N GMRCFIL
	885	S GMRCFIL =$S(GMRCSR V["99PRC": 123.3,1:12 3.5)
	886	Q:'$D(^GM R(GMRCFIL, +GMRCSRV,1 25))
	887	I '$D(GMR CDFN)!($G( UNRESOLV)) D Q
	888	. M @GMRC ARR=^GMR(G MRCFIL,+GM RCSRV,125)
	889	D BLRPLT^ TIUSRVD(,, GMRCDFN,,$ NA(^GMR(GM RCFIL,+GMR CSRV,125)) )
	890	I $D(^TMP ("TIUBOIL" ,$J)) M @G MRCARR=^TM P("TIUBOIL ",$J)
	891	K ^TMP("T IUBOIL",$J )
	892	Q
	893	;
	894	LOCKREC(GM RCDA) ;att empt to lo ck a consu lt record using orde r or recor d
	895	; Input:
	896	; GMRCD A = ien o f consult record fro m file 123
	897	;
	898	; Output:
	899	; 1 o r 0^reason can't be locked
	900	; 1 = succ essfully l ocked
	901	; 0 = coul dn't be lo cked
	902	N GMRCORD ,GMRCMSG
	903	S GMRCORD =$P($G(^GM R(123,GMRC DA,0)),U,3 )
	904	I $G(GMRC ORD) D ;a n order as sociated
	905	. S GMRCM SG=$$LOCK1 ^ORX2(GMRC ORD)
	906	. ; GMRCM SG=1 if lo cked or 0 if couldn 't be lock ed
	907	I $L($G(G MRCMSG)) Q GMRCMSG
	908	; no orde r = Inter- facility C onsult so lock consu lt record
	909	L +^GMR(1 23,GMRCDA) :5
	910	I '$T Q " 0^Another user is ed iting this record" ; couldn't lock it
	911	Q 1
	912	;
	913	UNLKREC(GM RCDA) ;unl ock a cons ult record
	914	; Input:
	915	; GMRCD A = ien o f consult record fro m file 123
	916	;
	917	N GMRCORD
	918	S GMRCORD =$P($G(^GM R(123,GMRC DA,0)),U,3 )
	919	I $G(GMRC ORD) D Q
	920	. D UNLK1 ^ORX2(GMRC ORD)
	921	L -^GMR(1 23,GMRCDA)
	922	Q
	923	GMRCCA (Ne w)
	924	GMRCCA ;SF VAMC/DAD - Consult C losure Too l: Report Prompting ;01/20/17 15:19
	925	;;3.0;CON SULT/REQUE ST TRACKIN G;89;D EC 27, 199 7;Build 16
	926	;Consult Closure To ol ;
	927	; IA# Us age C omponent
	928	; --------- ---------- --------
	929	; 4836 Pr ivate ^ DIC(40.7
	930	; 510 Con trolled ^D ISV(
	931	; 1519 Su pported E N^XUTMDEVQ
	932	; 2056 Su pported $ $GET1^DIQ
	933	; 2608 Su pported $ $TEST^DDBR T
	934	; 10024 Su pported W AIT^DICD
	935	; 10026 Su pported ^ DIR
	936	; 10063 Su pported ^ %ZTLOAD
	937	; 10103 Su pported $ $DT^XLFDT
	938	; 10104 Su pported $ $TRIM^XLFS TR
	939	; 10150 Su pported H LP^DDSUTL
	940	;
	941	EN ;
	942	; *** Inter active ent ry point
	943	N GM0CFG,GM APPT,GMDLI M,GMHEAD,G MAUTO,GMNO TE,GMOKAY
	944	N GMOPUT,GM TBEG,GMTEA M,GMTEXT,G MTEND,GMXL AT
	945	N DIR,DIROU T,DIRUT,DT OUT,DUOUT
	946	N X,Y,ZTCPU ,ZTDESC,ZT DTH,ZTIO,Z TKIL
	947	N ZTPRI,ZTR TN,ZTSAVE, ZTSK,ZTSYN C,ZTUCI
	948	S GMAUTO=0 ; 0-disabl e/1-enable consult a uto update (*DO NO T ENABLE *)
	949	;
	950	D PATCH^GMR CCX(.GMOKA Y)
	951	I GMOKAY'>0 G EXIT
	952	;
	953	K DIR
	954	S DIR(0)="P OAr^123.03 3:AEMNQZ"
	955	S DIR("A")= "Select CO NSULT CONF IGURATION: "
	956	S GM0CFG=$G (^DISV(DUZ ,$$GLOBROO T^GMRCCD(1 23.033)))
	957	I $$CHKCFG( +GM0CFG,1) >0 D
	958	. S DIR("B" )=$$GET1^D IQ(123.033 ,+GM0CFG,. 01)
	959	. Q
	960	S DIR("S")= "I $$CHKCF G^GMRCCA(+ Y,1)>0"
	961	W ! D ^DIR S GM0CFG=+ $G(Y)
	962	I $$DIREXIT >0 G EXIT
	963	;
	964	S GMHEAD="S elect a co nsult date range"
	965	D LASTMNTH^ GMRCCY($$D T^XLFDT,.G MTBEG,.GMT END)
	966	W ! I $$EN^ GMRCCY(.GM TBEG,.GMTE ND,GMHEAD, "U")'>0 G EXIT
	967	;
	968	K DIR
	969	S DIR(0)="S OA^1:Seen in clinic; 0:Not seen in clinic ;"
	970	S DIR("A",1 )="Select an appoint ment statu s for the report"
	971	S DIR("A",2 )=" "
	972	S DIR("A",3 )=" 1 - S een in cli nic"
	973	S DIR("A",4 )=" 0 - N ot seen in clinic"
	974	S DIR("A",5 )=" "
	975	S DIR("A")= "Select AP POINTMENT STATUS: "
	976	S DIR("B")= 1
	977	W ! D ^DIR S GMAPPT=+ $G(Y)
	978	I $$DIREXIT >0 G EXIT
	979	;
	980	K DIR
	981	S DIR(0)="S OA^1:Has a note;0:Do es not hav e a note;"
	982	S DIR("A",1 )="Select a note sta tus for th e report"
	983	S DIR("A",2 )=" "
	984	S DIR("A",3 )=" 1 - H as a note"
	985	S DIR("A",4 )=" 0 - D oes not ha ve a note"
	986	S DIR("A",5 )=" "
	987	S DIR("A")= "Select NO TE STATUS: "
	988	S DIR("B")= 1
	989	W ! D ^DIR S GMNOTE=+ $G(Y)
	990	I $$DIREXIT >0 G EXIT
	991	;
	992	S GMOPUT=0, GMXLAT=""
	993	I GMNOTE>0 D G:$$DIR EXIT>0 EXI T
	994	. K DIR
	995	. S DIR(0)= "YAO"
	996	. S DIR("A" )="Interac tive consu lt update: "
	997	. S DIR("B" )="Yes"
	998	. W ! D ^DI R S GMOPUT =+$G(Y)
	999	. S GMXLAT= "1^I"
	1000	. I GMOPUT> 0 I $$TEST ^DDBRT'>0 D
	1001	. . K GMTEXT
	1002	. . S GMTEXT (1)="* T he VA File Man browse r is not s upported b y your ter minal type *"
	1003	. . S GMTEXT (2)="* Y ou cannot use the in teractive consult up date on th is termina l *"
	1004	. . S GMTEXT ="*** You may print the consul t report a nd/or upda te the CPR S team * **"
	1005	. . D HANGMS G^GMRCCD(. GMTEXT,3,1 )
	1006	. . S GMOPUT =0,GMXLAT= ""
	1007	. . Q
	1008	. Q
	1009	;
	1010	I GMOPUT'>0 D G:$$DI REXIT>0 EX IT
	1011	. S GMTEAM= $$ISTM^GMR CCD(GM0CFG )
	1012	. K DIR
	1013	. S DIR(0)= "LOA^1:1:0 "
	1014	. S DIR("A" )="Select OUTPUT TYP E: "
	1015	. S DIR("A" ,1)="Selec t the outp ut type fo r the repo rt"
	1016	. S DIR("A" ,2)=" "
	1017	. S DIR("A" ,3)=" 1 - Print rep ort"
	1018	. S DIR("B" )="1"
	1019	. S GMXLAT= "1^P"
	1020	. I GMTEAM> 0 D
	1021	. . S DIR(0) ="LOA^1:2: 0"
	1022	. . S DIR("A ",4)=" 2 - Team upd ate"
	1023	. . S DIR("B ")="1,2"
	1024	. . S GMXLAT ="12^PT"
	1025	. . Q
	1026	. I (GMAUTO >0)&(GMNOT E>0) D
	1027	. . S DIR(0) ="LOA^1:2: 0"
	1028	. . S DIR("A ",4)=" 2 - Consult update"
	1029	. . S DIR("B ")="1,2"
	1030	. . S GMXLAT ="12^PC"
	1031	. . Q
	1032	. I (GMAUTO >0)&(GMTEA M>0)&(GMNO TE>0) D
	1033	. . S DIR(0) ="LOA^1:3: 0"
	1034	. . S DIR("A ",4)=" 2 - Team upd ate"
	1035	. . S DIR("A ",5)=" 3 - Consult update"
	1036	. . S DIR("B ")="1-3"
	1037	. . S GMXLAT ="123^PTC"
	1038	. . Q
	1039	. S DIR("A" ,1+$O(DIR( "A",1E25), -1))=" "
	1040	. W ! D ^DI R S GMOPUT =$G(Y)
	1041	. Q
	1042	S GMOPUT=$$ TRIM^XLFST R(GMOPUT," LR",",")
	1043	S GMOPUT=$T R(GMOPUT,$ P(GMXLAT,U ,1),$P(GMX LAT,U,2))
	1044	;
	1045	I GMOPUT["P " D G:$$D IREXIT>0 E XIT
	1046	. K DIR
	1047	. S DIR(0)= "YOA"
	1048	. S DIR("A" )="Delimit ed output: "
	1049	. S DIR("B" )="No"
	1050	. W ! D ^DI R S GMDLIM =+$G(Y)
	1051	. Q
	1052	E D
	1053	. S GMDLIM= 0
	1054	. Q
	1055	;
	1056	W !
	1057	S ZTRTN="TA SK^GMRCCA( "_GMTBEG_" ,"_GMTEND_ ","
	1058	S ZTRTN=ZTR TN_GM0CFG_ ","_GMAPPT _","_GMNOT E_","""
	1059	S ZTRTN=ZTR TN_GMOPUT_ ""","_GMDL IM_")"
	1060	S ZTDESC="C onsult Clo sure Tool"
	1061	I GMOPUT["P " D
	1062	. W !,"This report re quires a 1 32 column output dev ice"
	1063	. D EN^XUTM DEVQ(ZTRTN ,ZTDESC,.Z TSAVE,"MQ" ,1)
	1064	. Q
	1065	E D
	1066	. I GMOPUT[ "I" D
	1067	. . W !,"Sea rching for patient c onsults / appointmen ts / notes ",!
	1068	. . D WAIT^D ICD
	1069	. . D @ZTRTN
	1070	. . Q
	1071	. E D
	1072	. . S ZTIO=" "
	1073	. . D ^%ZTLO AD
	1074	. . Q
	1075	. Q
	1076	I $G(ZTSK)> 0 W !,"Tas k #",ZTSK
	1077	;
	1078	EXIT ;
	1079	; *** Commo n exit poi nt
	1080	Q
	1081	;
	1082	TASK(GMTBE G,GMTEND,G M0CFG,GMAP PT,GMNOTE, GMOPUT,GMD LIM) ;
	1083	; *** TaskM an entry p oint
	1084	N GMROOT
	1085	S GMROOT=$N A(^TMP($T( +0),$J))
	1086	K @GMROOT
	1087	D GETDATA^G MRCCB(GMRO OT,GMTBEG, GMTEND,GM0 CFG,GMAPPT ,GMNOTE,GM OPUT,GMDLI M)
	1088	I GMOPUT["C " D
	1089	. D CONSUPD T^GMRCCC(G MROOT)
	1090	. Q
	1091	I GMOPUT["T " D
	1092	. D MAKETEA M^GMRCCC(G MROOT,GM0C FG)
	1093	. Q
	1094	I GMOPUT["P " D
	1095	. D PRNTDAT A^GMRCCC(G MROOT,GMTB EG,GMTEND, GM0CFG,GMA PPT,GMNOTE ,GMDLIM)
	1096	. Q
	1097	I GMOPUT["I " D
	1098	. D INTERAC T^GMRCCD(G MROOT)
	1099	. Q
	1100	K @GMROOT
	1101	Q
	1102	;
	1103	CHKCFG(GM0 CFG,GMINAC ) ;
	1104	; *** Scree n for vali d consult configurat ion
	1105	N GMDATA,GM OKAY
	1106	S GMOKAY=1
	1107	I (GMINAC>0 )&($$GET1^ DIQ(123.03 3,GM0CFG,. 02,"I")>0) S GMOKAY= 0
	1108	I $$GET1^DI Q(123.033, GM0CFG,.04 )'>0 S GMO KAY=0
	1109	I $$GET1^DI Q(123.033, GM0CFG,.05 )'>0 S GMO KAY=0
	1110	S GMDATA("S TOP")=($$G ET1^DIQ(12 3.033,GM0C FG,.06,"I" )'>0)
	1111	F GMDATA="C LIN","CLPR ","CONP"," CONS","NOT E","PROT" D
	1112	. S GMDATA( GMDATA)=($ O(^GMR(123 .033,GM0CF G,GMDATA,0 ))'>0)
	1113	. Q
	1114	I (GMDATA(" CLPR"))&(G MDATA("CON P"))&(GMDA TA("CONS") )&(GMDATA( "PROT")) S
	1115	GMOKAY=0
	1116	I (GMDATA(" CLIN"))&(G MDATA("STO P")) S GMO KAY=0
	1117	I GMDATA("N OTE") S GM OKAY=0
	1118	Q GMOKAY
	1119	;
	1120	DIREXIT() ;
	1121	; *** DIR e xit status
	1122	Q $D(DIROUT )!$D(DIRUT )!$D(DTOUT )!$D(DUOUT )
	1123	;
	1124	POSTSAVE(G M0CFG) ;
	1125	; *** Post- save code for config editor
	1126	N GMTEXT
	1127	I $$CHKCFG( +GM0CFG,0) '>0 D
	1128	. S GMTEXT( 1)="* * * The consul t configur ation is i ncomplete, requiredd ata is mis sing. * * *"
	1129	. S GMTEXT( 2)="* * * You must e nter a Con fig Name, Days Cons- >Appt, Day s Appt->No te, * * *"
	1130	. S GMTEXT( 3)="* * * at least o ne type of Consult ( Service, P rocedure,e tc.), at l east * * *"
	1131	. S GMTEXT( 4)="* * * one Clinic and/or a Stop Code, and at le ast one No te Title. * * *"
	1132	. S GMTEXT( 5)="$$EOP"
	1133	. D HLP^DDS UTL(.GMTEX T)
	1134	. Q
	1135	Q
	1136	GMRCCB (N ew)
	1137	GMRCCB ;SF VAMC/DAD - Consult C losure Too l: Data Ga thering ;0 1/20/17 15 :19
	1138	;;3.0;CON SULT/REQUE ST TRACKIN G;89;D EC 27, 199 7;Build 16
	1139	;Consult Closure To ol ;
	1140	; IA# Us age C omponent
	1141	; --------- ---------- --------
	1142	; 2699 PRI VATE ^TIU(8 9.25,D0,0
	1143	; 6742 Co ntrolled S ub ^TIU(8 925,"ADCPT ",
	1144	; 2054 Su pported $$O REF^DILF
	1145	; 2056 Su pported $$G ET1^DIQ
	1146	; 4433 Su pported $$S DAPI^SDAMA 301
	1147	; 4837 Pr ivate ^ GMR(123,"E ",
	1148	; 10103 Su pported $ $FMADD^XLF DT
	1149	; 10103 Su pported $ $NOW^XLFDT
	1150	; 10105 Su pported $ $MIN^XLFMT H
	1151	;
	1152	GETDATA(GM ROOT,GMTBE G,GMTEND,G M0CFG,GMAP PT,GMNOTE, GMOPUT,GMD LIM) ;
	1153	; *** Get c onsults
	1154	N GM0CON,GM 0DFN,GMCLP R,GMPROC,G MPROT,GMSE RV,GMTCON
	1155	D CLINLIST^ GMRCCD(GMR OOT,GM0CFG )
	1156	S GMTCON=GM TBEG-.0000 001
	1157	F S GMTCON =$O(^GMR(1 23,"E",GMT CON)) Q:(G MTCON'>0)! (GMTCON>(G MTEND+.24) ) D
	1158	. S GM0CON= 0
	1159	. F S GM0C ON=$O(^GMR (123,"E",G MTCON,GM0C ON)) Q:GM0 CON'>0 D
	1160	. . I $$CONS CHEK(GM0CO N,.GMSERV, .GMPROC,.G MPROT,.GMC LPR) D
	1161	. .. S GM0DF N=$$GET1^D IQ(123,GM0 CON,.02,"I ")
	1162	. .. I GM0DF N>0 D
	1163	. ... D APPT CHEK(GMROO T,GM0CFG,G M0DFN,GM0C ON,GMTCON, GMAPPT,GMN OTE,GMOPUT )
	1164	. ... Q
	1165	. .. Q
	1166	. . Q
	1167	. Q
	1168	Q
	1169	;
	1170	CONSCHEK(G M0CON,GMSE RV,GMPROC, GMPROT,GMC LPR) ;
	1171	; *** Consu lt active & part of config?
	1172	N GMFILE,GM GLOB
	1173	I $$CONSOKA Y^GMRCCD(G M0CON)>0 D
	1174	. F GMFILE= 101,123.3 D
	1175	. . S GMGLOB (GMFILE)=$ $GLOBROOT^ GMRCCD(GMF ILE,";")
	1176	. . Q
	1177	. S GMSERV= $$GET1^DIQ (123,GM0CO N,1,"I")
	1178	. S GMCLPR= $$GET1^DIQ (123,GM0CO N,1.01,"I" )
	1179	. S (GMPROC ,GMPROT)=$ $GET1^DIQ( 123,GM0CON ,4,"I")
	1180	. S GMPROC= $S(GMPROC[ GMGLOB(123 .3):GMPROC ,1:"")
	1181	. S GMPROT= $S(GMPROT[ GMGLOB(101 ):GMPROT,1 :"")
	1182	. S GMCLPR( 0)=''$D(^R 1(123.033, GM0CFG,"CL PR","B",+G MCLPR))
	1183	. S GMSERV( 0)=''$D(^R 1(123.033, GM0CFG,"CO NS","B",+G MSERV))
	1184	. S GMPROC( 0)=''$D(^R 1(123.033, GM0CFG,"CO NP","B",+G MPROC))
	1185	. S GMPROT( 0)=''$D(^R 1(123.033, GM0CFG,"PR OT","B",+G MPROT))
	1186	. S GMSERV= $S(GMSERV( 0):$$GET1^ DIQ(123,GM 0CON,1),1: "")
	1187	. S GMCLPR= $S(GMCLPR( 0):$$GET1^ DIQ(123,GM 0CON,1.01) ,1:"")
	1188	. S GMPROC= $S(GMPROC( 0):$$GET1^ DIQ(123,GM 0CON,4),1: "")
	1189	. S GMPROT= $S(GMPROT( 0):$$GET1^ DIQ(123,GM 0CON,4),1: "")
	1190	. Q
	1191	E D
	1192	. S (GMSERV ,GMPROC,GM PROT,GMCLP R)=""
	1193	. S (GMSERV (0),GMPROC (0),GMPROT (0),GMCLPR (0))=0
	1194	. Q
	1195	Q (GMSERV(0 )!GMPROC(0 )!GMPROT(0 )!GMCLPR(0 ))
	1196	;
	1197	APPTCHEK(G MROOT,GM0C FG,GM0DFN, GM0CON,GMT CON,GMAPPT ,GMNOTE,GM OPUT) ;
	1198	; *** Check for appts
	1199	N GMTAPT
	1200	S GMTAPT=$$ APPTLIST(G MROOT,GM0C FG,GM0DFN, GMTCON,GMA PPT)
	1201	; Only seen Pts
	1202	I GMAPPT>0 D
	1203	. ; Pt has been seen
	1204	. I GMTAPT> 0 D
	1205	. . D NOTECH EK(GMROOT, GM0CFG,GM0 DFN,GM0CON ,GMTCON,GM TAPT,GMNOT E,GMOPUT)
	1206	. . Q
	1207	. Q
	1208	; Only unse en Pts
	1209	E D
	1210	. ; Pt has NOT been s een
	1211	. I (GMTAPT '>0)!($$UN SEEN^GMRCC D($P(GMTAP T,U,4))>0) D
	1212	. . D NOTECH EK(GMROOT, GM0CFG,GM0 DFN,GM0CON ,GMTCON,GM TAPT,GMNOT E,GMOPUT)
	1213	. . Q
	1214	. Q
	1215	Q
	1216	;
	1217	NOTECHEK(G MROOT,GM0C FG,GM0DFN, GM0CON,GMT CON,GMTAPT ,GMNOTE,GM OPUT) ;
	1218	; *** Check for notes
	1219	N GMTNOT
	1220	K @GMROOT@( "NOTE-LIST ")
	1221	S GMTNOT=$$ NOTELIST(G MROOT,GM0C FG,GM0DFN, +GMTAPT,+G MTCON,GMOP UT)
	1222	; Only Pts with notes
	1223	I GMNOTE>0 D
	1224	. ; Pt has note
	1225	. I GMTNOT> 0 D
	1226	. . D SETDAT A(GMROOT,G M0DFN,GM0C ON,GMTAPT, GMTNOT,GMO PUT)
	1227	. . Q
	1228	. Q
	1229	; Only Pts without no tes
	1230	E D
	1231	. ; Pt does NOT have note
	1232	. I GMTNOT' >0 D
	1233	. . I $O(@GM ROOT@("NOT E-LIST",0) )'>0 S @GM ROOT@("NOT E-LIST",1) ="^^NO NO TE" ; GMR CC2.11
	1234	. . D SETDAT A(GMROOT,G M0DFN,GM0C ON,GMTAPT, GMTNOT,GMO PUT)
	1235	. . Q
	1236	. Q
	1237	K @GMROOT@( "NOTE-LIST ")
	1238	Q
	1239	;
	1240	APPTLIST(G MROOT,GM0C FG,GM0DFN, GMTCON,GMA PPT) ;
	1241	; *** Get P t's appts
	1242	; $$APPTLIS T() = Appt Date ^ Cli nIEN ^ Cli nName ^ Ap ptStatInt ^ ApptStat Ext
	1243	N GMCLIN,GM DATA,GMDAT E,GMDAYS,G MFRST,GMLA ST
	1244	N GMLIST,GM SDAM,GMSTA T,GMTAPT,G MVSIT
	1245	S GMDAYS=$$ GET1^DIQ(1 23.033,GM0 CFG,.04)
	1246	S GMLAST=$$ FMADD^XLFD T(GMTCON,G MDAYS,0,0, 0)
	1247	S GMLAST=$$ MIN^XLFMTH (GMLAST,$$ NOW^XLFDT)
	1248	S GMSDAM("F LDS")="1;2 ;3"
	1249	S GMSDAM("S ORT")="P"
	1250	S GMSDAM(1) =GMTCON_"; "_GMLAST
	1251	S GMSDAM(2) =$$OREF^DI LF($NA(@GM ROOT@("XRE F-CLIN")))
	1252	S GMSDAM(4) =GM0DFN
	1253	S GMLIST=$N A(^TMP($J, "SDAMA301" ))
	1254	K @GMLIST
	1255	S GMVSIT=""
	1256	I $$SDAPI^S DAMA301(.G MSDAM)'=-1 D
	1257	. S GMTAPT= 0,GMFRST=" "
	1258	. F S GMTA PT=$O(@GML IST@(GM0DF N,GMTAPT)) Q:(GMTAPT '>0)!(GMVS IT>0) D
	1259	. . S GMDATA =$G(@GMLIS T@(GM0DFN, GMTAPT))
	1260	. . S GMCLIN =$P($P(GMD ATA,U,2)," ;",1)
	1261	. . S GMSTAT =$P($P(GMD ATA,U,3)," ;",1)
	1262	. . I (GMTAP T>0)&(GMCL IN>0) D
	1263	. .. ; Appt already us ed?
	1264	. .. I '$D(@ GMROOT@("X REF-APPT", GM0DFN,+GM CLIN,GMTAP T)) D
	1265	. ... ; Save first can celled/no- show appt
	1266	. ... I (GMF RST="")&($ $UNSEEN^GM RCCD(GMSTA T)>0) S GM FRST=GMDAT A
	1267	. ... ; Appt kept?
	1268	. ... I $$SE EN^GMRCCD( GMSTAT)>0 D
	1269	. .... ; Mar k appt use d
	1270	. .... S @GM ROOT@("XRE F-APPT",GM 0DFN,+GMCL IN,+GMTAPT )=""
	1271	. .... S GMV SIT=GMDATA
	1272	. .... Q
	1273	. ... Q
	1274	. .. Q
	1275	. . Q
	1276	. ; (No kep t appt fou nd) & (can celled/no- show appt found)
	1277	. I (GMVSIT '>0)&(GMFR ST]"")&(GM APPT'>0) D
	1278	. . S GMTAPT =$P(GMFRST ,U,1)
	1279	. . S GMCLIN =$P(GMFRST ,U,2)
	1280	. . ; Mark a ppt used
	1281	. . S @GMROO T@("XREF-A PPT",GM0DF N,+GMCLIN, +GMTAPT)=" "
	1282	. . S GMVSIT =GMFRST
	1283	. . Q
	1284	. Q
	1285	K @GMLIST
	1286	S GMDATE=$P (GMVSIT,U, 1)
	1287	S GMCLIN("I ")=$P($P(G MVSIT,U,2) ,";",1)
	1288	S GMCLIN("E ")=$P($P(G MVSIT,U,2) ,";",2)
	1289	S GMSTAT("I ")=$P($P(G MVSIT,U,3) ,";",1)
	1290	S GMSTAT("E ")=$P($P(G MVSIT,U,3) ,";",2)
	1291	S GMVSIT=GM DATE_U_GMC LIN("I")_U _GMCLIN("E ")_U
	1292	S GMVSIT=GM VSIT_GMSTA T("I")_U_G MSTAT("E")
	1293	Q GMVSIT
	1294	;
	1295	NOTELIST(G MROOT,GM0C FG,GM0DFN, GMTAPT,GMT CON,GMOPUT ) ;
	1296	; *** Get P t's notes
	1297	; $$NOTELIS T() = RefD ate ^ Titl eIEN ^ Tit leName ^ N oteIEN
	1298	N GM0NOT,GM CLAS,GMDAT A,GMDATE,G MDAYS,GMIN DX
	1299	N GMTFIN,GM STAT,GMTIT L,GMTNOT,G M0TTL
	1300	S GMDATE=$S (GMTAPT>0: GMTAPT,1:G MTCON)
	1301	S GMDAYS=$$ GET1^DIQ(1 23.033,GM0 CFG,$S(GMT APT>0:.05, 1:.04))
	1302	S GMTFIN=99 99999-$$FM ADD^XLFDT( GMDATE\1,G MDAYS,0,0, 0)
	1303	D NOTESTAT^ GMRCCD(.GM STAT)
	1304	S (GMCLAS,G MTITL)=0
	1305	F S GMCLAS =$O(^TIU(8 925,"ADCPT ",GM0DFN,G MCLAS)) Q: $$NOTEQUIT (GMCLAS,GM TITL,GMOPU T) D
	1306	. S GMSTAT= 0
	1307	. F S GMST AT=$O(GMST AT(GMSTAT) ) Q:$$NOTE QUIT(GMSTA T,GMTITL,G MOPUT) D
	1308	. . S GMTNOT =9999999-( GMDATE\1)
	1309	. . F S GMT NOT=$O(^TI U(8925,"AD CPT",GM0DF N,GMCLAS,G MSTAT,GMTN OT),-1) Q: $$NOTEQUIT (GMTNOT,GM TITL,GMOPU T)!(GMTNOT <GMTFIN) D
	1310	. .. S GM0NO T=0
	1311	. .. F S GM 0NOT=$O(^T IU(8925,"A DCPT",GM0D FN,GMCLAS, GMSTAT,GMT NOT,GM0NOT )) Q:$$NOT EQUIT(GM0N OT,GMTITL, GMOPUT) D
	1312	. ... ; Note part of c onfig?
	1313	. ... S GM0T TL=$$GET1^ DIQ(8925,G M0NOT,.01, "I")
	1314	. ... I $D(^ R1(123.033 ,GM0CFG,"N OTE","B",+ GM0TTL)) D
	1315	. .... S GMD ATA=$$GET1 ^DIQ(8925, GM0NOT,130 1,"I")
	1316	. .... S GMD ATA=GMDATA _U_$$GET1^ DIQ(8925,G M0NOT,.01, "I")
	1317	. .... S GMD ATA=GMDATA _U_$$GET1^ DIQ(8925,G M0NOT,.01)
	1318	. .... S GMD ATA=GMDATA _U_GM0NOT
	1319	. .... I ((G MOPUT["I") !(GMOPUT[" P"))&(GMOP UT'["C") D
	1320	. ..... S GM INDX=1+$O( @GMROOT@(" NOTE-LIST" ,1E25),-1)
	1321	. ..... S @G MROOT@("NO TE-LIST",G MINDX)=GMD ATA
	1322	. ..... Q
	1323	. .... ; Not e already used?
	1324	. .... I '$D (@GMROOT@( "XREF-NOTE ",GM0DFN,G M0NOT)) D
	1325	. ..... ; Ma rk note us ed
	1326	. ..... S @G MROOT@("XR EF-NOTE",G M0DFN,GM0N OT)=""
	1327	. ..... S GM TITL=GMDAT A
	1328	. ..... Q
	1329	. .... Q
	1330	. ... Q
	1331	. .. Q
	1332	. . Q
	1333	. Q
	1334	Q GMTITL
	1335	;
	1336	NOTEQUIT(G MORDR,GMTI TL,GMOPUT) ;
	1337	; *** Stop note searc h?
	1338	Q $S(GMORDR '>0:1,GMOP UT["I":0,1 :''GMTITL)
	1339	;
	1340	SETDATA(GM ROOT,GM0DF N,GM0CON,G MADAT,GMND AT,GMOPUT) ;
	1341	; *** Save report dat a
	1342	N GMCLIN,GM CLPR,GMCNA M,GMDATA,G MINDX,GMNA ME
	1343	N GMNOTE,GM PROC,GMPRO T,GMSERV,G MSSN,GMSTA T
	1344	N GMTAPT,GM TCON,GMTNO T
	1345	S GMTCON=$$ GET1^DIQ(1 23,GM0CON, 3,"I")
	1346	S GMCNAM="* NO CONSULT *"
	1347	I $$CONSCHE K(GM0CON,. GMSERV,.GM PROC,.GMPR OT,.GMCLPR ) D
	1348	. I GMCLPR( 0) S GMCNA M=GMCLPR
	1349	. I GMPROT( 0) S GMCNA M=GMPROT
	1350	. I GMPROC( 0) S GMCNA M=GMPROC
	1351	. I GMSERV( 0) S GMCNA M=GMSERV
	1352	. Q
	1353	S GMCNAM=GM CNAM_U_(+G M0CON)
	1354	;
	1355	S GMNAME=$$ GET1^DIQ(2 ,GM0DFN,.0 1)
	1356	S GMNAME=$S (GMNAME]"" :GMNAME,1: "NO PATIE NT")
	1357	S GMNAME=GM NAME_U_(+G M0DFN)
	1358	S GMSSN=$$G ET1^DIQ(2, GM0DFN,.09 )
	1359	;
	1360	S GMCLIN=$P (GMADAT,U, 3)
	1361	S GMCLIN=$S (GMCLIN]"" :GMCLIN,1: "NO CLINI C")
	1362	S GMCLIN=GM CLIN_U_(+$ P(GMADAT,U ,2))
	1363	S GMTAPT=$P (GMADAT,U, 1)
	1364	S GMSTAT("I ")=$P(GMAD AT,U,4)
	1365	S GMSTAT("E ")=$P(GMAD AT,U,5)
	1366	;
	1367	S GMNOTE=$P (GMNDAT,U, 3)
	1368	S GMNOTE=$S (GMNOTE]"" :GMNOTE,1: "NO NOTE ")
	1369	S GMNOTE=GM NOTE_U_(+$ P(GMNDAT,U ,2))_U_(+$ P(GMNDAT,U ,4))
	1370	S GMTNOT=$P (GMNDAT,U, 1)
	1371	;
	1372	S GMDATA=GM SSN_U_GMTC ON_U_GMTAP T_U
	1373	S GMDATA=GM DATA_GMSTA T("I")_U_G MSTAT("E") _U
	1374	S GMDATA=GM DATA_GMTNO T_U_GM0CON _U_(+$P(GM NDAT,U,4)) _U
	1375	S GMDATA=GM DATA_"0"_U _""
	1376	;
	1377	; Data = SS N ^ Consul tDate ^ Ap ptDate ^ A pptStatusI nt ^ ApptS tatusExt ^
	1378	; No teDate ^ C onsultIEN ^ NoteIEN ^ ConsultU pdated ^ C onsultUpda teMsg
	1379	;
	1380	I ((GMOPUT[ "I")!(GMOP UT["P"))&( GMOPUT'["C ") D
	1381	. S GMINDX= 0
	1382	. F S GMIN DX=$O(@GMR OOT@("NOTE -LIST",GMI NDX)) Q:GM INDX'>0 D
	1383	. . S GMNOTE =$G(@GMROO T@("NOTE-L IST",GMIND X))
	1384	. . S $P(GMD ATA,U,6)=$ P(GMNOTE,U ,1)
	1385	. . S $P(GMD ATA,U,8)=$ P(GMNOTE,U ,4)
	1386	. . S GMNOTE =$P(GMNOTE ,U,3)_U_$P (GMNOTE,U, 2)_U_$P(GM NOTE,U,4)
	1387	. . I GMOPUT ["I" D
	1388	. .. ; Root( "DATA", Pt Name ^ PtI EN, Consul t ^ Consul tIEN,
	1389	. .. ; Title ^ Ti tleIEN ^ N oteIEN) = Data
	1390	. .. S @GMRO OT@("DATA" ,GMNAME,GM CNAM,GMNOT E)=GMDATA
	1391	. .. Q
	1392	. . E D
	1393	. .. ; Root( "DATA", Co nsult ^ Co nsultIEN, Clin ^ Cli nIEN,
	1394	. .. ; PtName ^ P tIEN, Titl e ^ TitleI EN ^ NoteI EN) = Data
	1395	. .. S @GMRO OT@("DATA" ,GMCNAM,GM CLIN,GMNAM E,GMNOTE)= GMDATA
	1396	. .. Q
	1397	. . Q
	1398	. Q
	1399	E D
	1400	. ; Root("D ATA", Cons ult ^ Cons ultIEN, Cl in ^ ClinI EN,
	1401	. ; Ti tle ^ Titl eIEN ^ Not eIEN, PtNa me ^ PtIEN ) = Data
	1402	. S @GMROOT @("DATA",G MCNAM,GMCL IN,GMNOTE, GMNAME)=GM DATA
	1403	. Q
	1404	S @GMROOT@( "XREF-DFN" ,GM0DFN)=" "
	1405	Q
	1406	GMRCCC (Ne w)
	1407	GMRCCC ; SFVAMC/DAD - Consult Closure T ool: Outpu t Data ;01 /20/17 15: 19
	1408	;;3.0;C ONSULT/REQ UEST TRACK ING;89 ;DEC 27, 1 997;Build 16
	1409	;Consult Closure T ool
	1410	; IA# Usage Componen t
	1411	; --------- ---------- --------
	1412	; 2699 Pr ivate ^TIU(8925 ,D0,0
	1413	; 3005 Co ntroled ^ OR(100.21
	1414	; 2051 Su pported $ $FIND1^DIC
	1415	; 2051 Su pported L IST^DIC
	1416	; 2053 Su pported U PDATE^DIE
	1417	; 2054 Su pported C LEAN^DILF
	1418	; 2056 Su pported $ $GET1^DIQ
	1419	; 2980 Co ntrolled $ $SFILE^GMR CGUIB
	1420	; 3473 Pr ivate G ET^GMRCTIU
	1421	; 10026 Su pported ^ DIR
	1422	; 10081 Su pported S ETUP^XQALE RT
	1423	; 10089 Su pported ^ %ZISC
	1424	; 10103 Su pported $ $DT^XLFDT
	1425	; 10103 Su pported $ $FMTE^XLFD T
	1426	; 10103 Su pported $ $NOW^XLFDT
	1427	;
	1428	PRNTDATA(G MROOT,GMTB EG,GMTEND, GM0CFG,GMA PPT,GMNOTE ,GMDLIM) ;
	1429	; *** Print the data
	1430	N GMCLIN,GM CONS,GMEXI T,GMNAME,G MPAGE,GMTI TL
	1431	U IO
	1432	S (GMEXIT,G MPAGE)=0
	1433	D HEADER(.G MPAGE,GMTB EG,GMTEND, GM0CFG,GMA PPT,GMNOTE ,GMDLIM)
	1434	S GMCONS=""
	1435	I $O(@GMROO T@("DATA", GMCONS))=" " D
	1436	. D WRITE(" !!","* N o data fou nd *",21 ,GMDLIM)
	1437	. Q
	1438	F S GMCONS =$O(@GMROO T@("DATA", GMCONS)) Q :GMCONS="" !GMEXIT D
	1439	. S GMCLIN= ""
	1440	. F S GMCL IN=$O(@GMR OOT@("DATA ",GMCONS,G MCLIN)) Q: GMCLIN=""! GMEXIT D
	1441	. . S GMNAME =""
	1442	. . F S GMN AME=$O(@GM ROOT@("DAT A",GMCONS, GMCLIN,GMN AME)) Q:GM NAME=""!GM EXIT D
	1443	. .. S GMTIT L=""
	1444	. .. F S GM TITL=$O(@G MROOT@("DA TA",GMCONS ,GMCLIN,GM NAME,GMTIT L)) Q:GMTI TL=""!GMEX IT D
	1445	. ... D PRIN T(GMROOT,G MCONS,GMCL IN,GMTITL, GMNAME,GMD LIM)
	1446	. ... D PAUS E(.GMEXIT, .GMPAGE,GM TBEG,GMTEN D,GM0CFG,G MAPPT,GMNO TE,GMDLIM)
	1447	. ... Q
	1448	. .. Q
	1449	. . Q
	1450	. Q
	1451	D ^%ZISC
	1452	Q
	1453	;
	1454	PRINT(GMRO OT,GMCONS, GMCLIN,GMT ITL,GMNAME ,GMDLIM) ;
	1455	; *** Print one recor d
	1456	; Array("DA TA", Consu lt^IEN, Cl inic^IEN, Note^IEN, Patient^IE N) =
	1457	; SSN ^ C onsultDate ^ ApptDat e ^ ApptSt atusInt ^ ApptStatus Ext ^ Note Date
	1458	N GMDATA
	1459	S GMDATA=$G (@GMROOT@( "DATA",GMC ONS,GMCLIN ,GMNAME,GM TITL))
	1460	D WRITE("!! ",$P(GMNAM E,U,1),30, GMDLIM) ; Pt Name
	1461	D WRITE("?3 4",$P(GMDA TA,U,1),10 ,GMDLIM) ; SSN
	1462	D WRITE("?4 8",$P(GMCO NS,U,1),63 ,GMDLIM) ; Consult T itle
	1463	D WRITE("?1 15",$$DATE ($P(GMDATA ,U,2),"2MZ "),14,GMDL IM) ; Cons ult Date
	1464	D WRITE("!" ,$P(GMCLIN ,U,1),30,G MDLIM) ; A ppt Clinic
	1465	D WRITE("?3 4",$$DATE( $P(GMDATA, U,3),"2MZ" ),14,GMDLI M) ; Appt Date
	1466	D WRITE("?6 5",$P(GMDA TA,U,5),33 ,GMDLIM) ; Appt Stat us
	1467	D WRITE("!" ,$P(GMTITL ,U,1),60,G MDLIM) ; N ote Title
	1468	D WRITE("?6 5",$$DATE( $P(GMDATA, U,6),"2MZ" ),14,GMDLI M) ; Note Date
	1469	D WRITE("?1 15",$$BOOL ($P(GMDATA ,U,9)),3,G MDLIM) ; C onsult Upd ated
	1470	W :GMDLIM>0 !
	1471	Q
	1472	;
	1473	DATE(GMDAT E,GMFORM) ;
	1474	; *** Forma t dates
	1475	Q $S(GMDATE >0:$$FMTE^ XLFDT(GMDA TE,GMFORM) ,1:"")
	1476	;
	1477	BOOL(GMBOO L) ;
	1478	; *** Forma t boolean
	1479	Q $S(''GMBO OL:"Yes",1 :"No")
	1480	;
	1481	PAUSE(GMEX IT,GMPAGE, GMTBEG,GMT END,GM0CFG ,GMAPPT,GM NOTE,GMDLI M) ;
	1482	; *** Pause at end of page
	1483	N DIR,DIROU T,DIRUT,DT OUT,DUOUT, X,Y
	1484	I (GMDLIM'> 0)&($Y>(IO SL-5)) D
	1485	. I $E(IOST ,1,2)="C-" K DIR S D IR(0)="E" D ^DIR S G MEXIT='$G( Y)
	1486	. I GMEXIT' >0 D HEADE R(.GMPAGE, GMTBEG,GMT END,GM0CFG ,GMAPPT,GM NOTE,GMDLI M)
	1487	. Q
	1488	Q
	1489	;
	1490	HEADER(GMP AGE,GMTBEG ,GMTEND,GM 0CFG,GMAPP T,GMNOTE,G MDLIM) ;
	1491	; *** Page header
	1492	S GMPAGE=GM PAGE+1
	1493	I (GMDLIM'> 0)&(($E(IO ST,1,2)="C -")!(GMPAG E>1)) W @I OF
	1494	D CENTER("C onsult Clo sure Tool" ,GMDLIM)
	1495	I GMDLIM'>0 D WRITE(" ?115",$$DA TE($$DT^XL FDT,"2DZ") ,8,GMDLIM)
	1496	D CENTER("C onsults fr om "_$$DAT E(GMTBEG," 2DZ")_" to "_$$DATE( GMTEND,"2D Z"),GMDLIM )
	1497	I GMDLIM'>0 D WRITE(" ?115","Pag e: "_GMPAG E,9,GMDLIM )
	1498	D CENTER("C onsult con figuration : "_$$GET1 ^DIQ(123.0 33,GM0CFG, .01),GMDLI M)
	1499	D CENTER("A ppointment status: " _$S(GMAPPT >0:"Seen", 1:"Not see n")_" in c linic",GMD LIM)
	1500	D CENTER("N ote status : "_$S(GMN OTE>0:"Has ",1:"Does not have") _" a note" ,GMDLIM)
	1501	D WRITE("!! ","Patient Name",12, GMDLIM)
	1502	D WRITE("?3 4","SSN",3 ,GMDLIM)
	1503	D WRITE("?4 8","Consul t Title",1 3,GMDLIM)
	1504	D WRITE("?1 15","Consu lt Date",1 2,GMDLIM)
	1505	D WRITE("!" ,"Appt Cli nic",11,GM DLIM)
	1506	D WRITE("?3 4","Appt D ate",9,GMD LIM)
	1507	D WRITE("?6 5","Appt S tatus",11, GMDLIM)
	1508	D WRITE("!" ,"Note Tit le",10,GMD LIM)
	1509	D WRITE("?6 5","Note D ate",9,GMD LIM)
	1510	D WRITE("?1 15","Consu lt Updated ",15,GMDLI M)
	1511	I GMDLIM'>0 D WRITE(" !",$TR($J( "",IOM)," ","-"),IOM ,GMDLIM)
	1512	W :GMDLIM>0 !
	1513	Q
	1514	;
	1515	WRITE(GMFM T,GMDATA,G MLEN,GMDLI M) ;
	1516	; *** Outpu t the data
	1517	W :(GMDLIM'> 0)&(GMLEN> 0) @GMFMT
	1518	W $S(GMDLIM '>0:$E(GMD ATA,1,GMLE N),1:GMDAT A)
	1519	W :GMDLIM>0 U
	1520	Q
	1521	;
	1522	CENTER(GMD ATA,GMDLIM ) ;
	1523	; *** Cente r data
	1524	D WRITE("!? "_(IOM-$L( GMDATA)\2) ,GMDATA,$L (GMDATA),G MDLIM)
	1525	W :GMDLIM>0 !
	1526	Q
	1527	;
	1528	MAKETEAM(G MROOT,GM0C FG) ;
	1529	; *** Updat e the CPRS team
	1530	N GM0DFN,GM 0TM,GM1TM, GMDPT,GMIE NS,GMINDX, GMLIST
	1531	; Is there a team ass ociated wi th the sel ected conf iguration?
	1532	I $$ISTM^GM RCCD(GM0CF G)>0 D
	1533	. S GM0TM=$ $GET1^DIQ( 123.033,GM 0CFG,.03," I")
	1534	. S GMLIST= $NA(^TMP(" DILIST",$J ))
	1535	. K @GMLIST ,@GMROOT@( "TEAM-FDA" )
	1536	. S GMDPT=$ $GLOBROOT^ GMRCCD(2," ;")
	1537	. ; Get cur rent list of patient s in team
	1538	. D LIST^DI C(100.2101 ,","_GM0TM _",")
	1539	. D CLEAN^D ILF
	1540	. S GMINDX= 0
	1541	. ; Make FD A array to delete cu rrent pati ents from team
	1542	. F S GMIN DX=$O(@GML IST@(2,GMI NDX)) Q:GM INDX'>0 D
	1543	. . S GM1TM= $G(@GMLIST @(2,GMINDX ))
	1544	. . S GMIENS =GM1TM_"," _GM0TM_","
	1545	. . I GM1TM> 0 S @GMROO T@("TEAM-F DA",100.21 01,GMIENS, .01)="@"
	1546	. . Q
	1547	. K @GMLIST
	1548	. ; Delete current pa tients fro m team
	1549	. I $D(@GMR OOT@("TEAM -FDA")) D
	1550	. . D UPDATE ^DIE("",$N A(@GMROOT@ ("TEAM-FDA ")))
	1551	. . D CLEAN^ DILF
	1552	. . Q
	1553	. K @GMROOT @("TEAM-FD A")
	1554	. S GM0DFN= 0
	1555	. ; Make FD A array to add new p atients to team
	1556	. F S GM0D FN=$O(@GMR OOT@("XREF -DFN",GM0D FN)) Q:GM0 DFN'>0 D
	1557	. . S GMIENS ="+"_GM0DF N_","_GM0T M_","
	1558	. . S @GMROO T@("TEAM-F DA",100.21 01,GMIENS, .01)=GM0DF N_GMDPT
	1559	. . Q
	1560	. ; Add new patients to team
	1561	. I $D(@GMR OOT@("TEAM -FDA")) D
	1562	. . D UPDATE ^DIE("",$N A(@GMROOT@ ("TEAM-FDA ")))
	1563	. . D CLEAN^ DILF
	1564	. . Q
	1565	. K @GMROOT @("TEAM-FD A")
	1566	. D TEAMALR T(GM0CFG)
	1567	. Q
	1568	Q
	1569	;
	1570	TEAMALRT(G M0CFG) ;
	1571	; *** Alert users whe n team is updated
	1572	N GM0DUZ,GM 0TM,GMINDX ,GMLIST,XQ A,XQAARCH, XQADATA
	1573	N XQAFLG,XQ AID,XQAMSG ,XQAOPT,XQ AROU,XQASU PV,XQASURO
	1574	S GM0TM=$$G ET1^DIQ(12 3.033,GM0C FG,.03,"I" )
	1575	S GMLIST=$N A(^TMP("DI LIST",$J))
	1576	K @GMLIST
	1577	D LIST^DIC( 100.212,", "_GM0TM_", ")
	1578	D CLEAN^DIL F
	1579	S GMINDX=0
	1580	F S GMINDX =$O(@GMLIS T@(2,GMIND X)) Q:GMIN DX'>0 D
	1581	. S GM0DUZ= $G(@GMLIST @(2,GMINDX ))
	1582	. I GM0DUZ> 0 S XQA(GM 0DUZ)=""
	1583	. Q
	1584	K @GMLIST
	1585	S GM0DUZ=$$ GET1^DIQ(1 00.21,GM0T M,1.6,"I")
	1586	I GM0DUZ>0 S XQA(GM0D UZ)=""
	1587	S XQA(DUZ)= ""
	1588	S XQAMSG="C onsult Clo sure Tool has update d '"
	1589	S XQAMSG=XQ AMSG_$$GET 1^DIQ(123. 033,GM0CFG ,.03)_"' t eam"
	1590	S XQAID=$T( +0)_";"_DU Z_";"_$$NO W^XLFDT
	1591	D SETUP^XQA LERT
	1592	Q
	1593	;
	1594	CONSUPDT(G MROOT) ;
	1595	; *** Updat e the cons ults non-i nteractive ly
	1596	N GM0CON,GM 0NOT,GMCLI N,GMCONS,G MDATA
	1597	N GMMSG,GMN AME,GMTITL ,GMUPDT
	1598	S GMCONS=""
	1599	F S GMCONS =$O(@GMROO T@("DATA", GMCONS)) Q :GMCONS="" D
	1600	. S GMCLIN= ""
	1601	. F S GMCL IN=$O(@GMR OOT@("DATA ",GMCONS,G MCLIN)) Q: GMCLIN="" D
	1602	. . S GMTITL =""
	1603	. . F S GMT ITL=$O(@GM ROOT@("DAT A",GMCONS, GMCLIN,GMT ITL)) Q:GM TITL="" D
	1604	. .. S GMNAM E=""
	1605	. .. F S GM NAME=$O(@G MROOT@("DA TA",GMCONS ,GMCLIN,GM TITL,GMNAM E)) Q:GMNA ME="" D
	1606	. ... S GMDA TA=$G(@GMR OOT@("DATA ",GMCONS,G MCLIN,GMTI TL,GMNAME) )
	1607	. ... S GM0C ON=$P(GMDA TA,U,7)
	1608	. ... S GM0N OT=$P(GMDA TA,U,8)
	1609	. ... I (GM0 CON>0)&(GM 0NOT>0) D
	1610	. .... S GMU PDT=$$CONU PDT(GM0CON ,GM0NOT,.G MMSG)
	1611	. .... S $P( GMDATA,U,9 ,10)=GMUPD T_U_$G(GMM SG)
	1612	. .... S @GM ROOT@("DAT A",GMCONS, GMCLIN,GMT ITL,GMNAME )=GMDATA
	1613	. .... Q
	1614	. ... Q
	1615	. .. Q
	1616	. . Q
	1617	. Q
	1618	Q
	1619	;
	1620	CONUPDT(GM 0CON,GM0NO T,GMMSG) ;
	1621	; *** Updat e a consul t
	1622	N GMALRT,GM AUTH,GMDUZ ,GMFIND,GM NOW
	1623	N GMOKAY,GM STAT,GMTO, GMRCADUZ K GMMSG
	1624	; Get note status, co mpute cons ult status
	1625	D NOTESTAT^ GMRCCD(.GM STAT)
	1626	S GMAUTH=$$ GET1^DIQ(8 925,GM0NOT ,1202,"I")
	1627	S GMSTAT=$$ GET1^DIQ(8 925,GM0NOT ,.05,"I")
	1628	I $D(GMSTAT (+GMSTAT)) #2>0 S GMS TAT="COMPL ETED"
	1629	E S GMSTAT ="INCOMPLE TE"
	1630	; Update a consult wi th a TIU n ote
	1631	D GET^GMRCT IU(GM0CON, GM0NOT,GMS TAT,GMAUTH )
	1632	; Get recip ients of c onsult not ification
	1633	D EN^GMRCT( $$GET1^DIQ (123,GM0CO N,1,"I"))
	1634	S (GMTO,GMD UZ)=""
	1635	F S GMDUZ= $O(GMRCADU Z(GMDUZ)) Q:GMDUZ'>0 D
	1636	. S GMTO=GM TO_GMDUZ_$ S($O(GMRCA DUZ(GMDUZ) )>0:";",1: "")
	1637	. Q
	1638	S GMALRT=$S (GMSTAT="C OMPLETED": 0,1:1)
	1639	S GMFIND="U "
	1640	S GMNOW=$$N OW^XLFDT
	1641	S GMMSG(1)= "Administr ative clos ure perfor med"
	1642	S GMMSG(2)= "by the Co nsult Clos ure Tool."
	1643	S GMSTAT=$$ FIND1^DIC( 123.1,""," X","COMPLE TE/UPDATE" ,"B")
	1644	; Administr ative comp letion of a consult
	1645	S GMOKAY=$$ SFILE^GMRC GUIB(GM0CO N,GMSTAT,G MFIND,GMAU TH,DUZ,.GM MSG,GMALRT ,GMTO,GMNO W)
	1646	K GMMSG S G MMSG=$P(GM OKAY,U,2)
	1647	Q '$P(GMOKA Y,U,1)
	1648	GMRCCD (Ne w)
	1649	GMRCCD ;SF VAMC/DAD - Consult C losure Too l: Interac tive Consu lt Update ;01/20/17 15:19
	1650	; ;3.0;CONSU LT/REQUEST TRACKING; 89;DEC 27, 1997; Build 16
	1651	; Consult Cl osure Tool
	1652	; IA# Us age C omponent
	1653	; --------- ---------- --------
	1654	; 4836 Pr ivate $$GET1^D IQ(123.033 ,GM0CFG,.0 6,"I")
	1655	; 3005 Co ntrolled $$GET1^DIQ (123.033,G M0CFG,".03 :1","I")
	1656	; 10040 Su pported $ $GET1^DIQ( 123.033,GM 0CFG,.06
	1657	; 4072 Co ntrolled $$FIND1^D IC(8925.6
	1658	; 2051 Su pported $$FIND1^D IC
	1659	; 2051 Su pported LIST^DIC
	1660	; 2052 Su pported $$GET1^DI D
	1661	; 2054 Su pported CLEAN^DIL F
	1662	; 2056 Su pported $$GET1^DI Q
	1663	; 2607 Su pported DOCLIST^D DBR
	1664	; 2832 Co ntrolled RPC^TIUSR V
	1665	; 2925 Co ntrolled DT^GMRCSL M2
	1666	; 10026 Su pported ^DIR
	1667	; 10086 Su pported HOME^%ZIS
	1668	; 10096 Su pported ^%ZOSF(
	1669	;
	1670	INTERACT(G MROOT) ;
	1671	; *** Inter active con sult updat e
	1672	N GM0CON,GM 0NOT,GMCCN T,GMCONS,G MCRPT,GMDO CS
	1673	N GMEXIT,GM INDX,GMNAM E,GMNCNT,G MNOTE,GMNR PT
	1674	N GMNTXT,GM PCNT,GMTEX T,GMTITL,G MRCOER,GMR CQUT
	1675	D HOME^%ZIS
	1676	S GMDOCS=$N A(@GMROOT@ ("DOCS-LIS T"))
	1677	S GMNRPT=$N A(@GMROOT@ ("NOTE-TEX T"))
	1678	S GMCRPT=$N A(^TMP("GM RCR",$J,"D T"))
	1679	S GMNOTE=$N A(^TMP("TI UAUDIT",$J ))
	1680	D COUNT(GMR OOT,.GMPCN T,.GMCCNT, .GMNCNT)
	1681	S GMPCNT(0) =GMPCNT
	1682	S GMCCNT(0) =GMCCNT
	1683	S GMNCNT(0) =GMNCNT
	1684	K GMTEXT
	1685	S GMTEXT(1) ="The Cons ult Closur e Tool has identifie d"
	1686	S GMTEXT(2) =" Patien ts: "_$J(G MPCNT,4)
	1687	S GMTEXT(3) =" Consul ts: "_$J(G MCCNT,4)
	1688	S GMTEXT(4) =" Notes: "_$J(G MNCNT,4)
	1689	S GMTEXT(5) ="that mee t your sel ected crit eria."
	1690	S GMTEXT(6) =""
	1691	S GMTEXT="E nter RETUR N to conti nue: "
	1692	D HANGMSG(. GMTEXT,$G( DTIME,900) ,1)
	1693	S GMNAME="" ,(GMEXIT,G MPCNT,GMCC NT,GMNCNT) =0
	1694	I $O(@GMROO T@("DATA", GMNAME))=" " D
	1695	. K GMTEXT S GMTEXT=" * No dat a found *"
	1696	. D HANGMSG (.GMTEXT,0 ,1)
	1697	. Q
	1698	F S GMNAME =$O(@GMROO T@("DATA", GMNAME)) Q :(GMNAME=" ")!(GMEXIT >0) D
	1699	. S GMPCNT= GMPCNT+1
	1700	. S GMCONS= ""
	1701	. F S GMCO NS=$O(@GMR OOT@("DATA ",GMNAME,G MCONS)) Q: (GMCONS="" )!(GMEXIT> 0) D
	1702	. . S GMCCNT =GMCCNT+1
	1703	. . K @GMCRP T,@GMDOCS, @GMNRPT
	1704	. . ; Get co nsult text
	1705	. . S GM0CON =$P(GMCONS ,U,2)
	1706	. . S GMRCOE R=2
	1707	. . K GMRCQU T
	1708	. . D DT^GMR CSLM2(GM0C ON)
	1709	. . I $G(GMR CQUT)'>0 D
	1710	. .. S GMTIT L="",GMIND X=0
	1711	. .. F S GM TITL=$O(@G MROOT@("DA TA",GMNAME ,GMCONS,GM TITL)) Q:( GMTITL="") !(GMEXIT>0 ) D
	1712	. ... S GMNC NT=GMNCNT+ 1
	1713	. ... S GM0N OT=$P(GMTI TL,U,3)
	1714	. ... ; Buil d browser doc list
	1715	. ... I (GM0 CON>0)&(GM 0NOT>0) D
	1716	. .... S GMI NDX=GMINDX +1
	1717	. .... ; Add consult t o doc list
	1718	. .... S GMT EXT="Consu lt Narrati ve"
	1719	. .... S GMT EXT=GMTEXT _" ("_GMCC NT_" of "_ GMCCNT(0)_ ")"
	1720	. .... S @GM DOCS@(GMTE XT)=GMCRPT
	1721	. .... ; Get progress note text
	1722	. .... K @GM NOTE
	1723	. .... D RPC ^TIUSRV(.G MNOTE,GM0N OT)
	1724	. .... S GMN TXT=$NA(@G MNRPT@(GM0 NOT))
	1725	. .... M @GM NTXT=@GMNO TE
	1726	. .... K @GM NOTE
	1727	. .... ; Add progress note to do c list
	1728	. .... S GMT EXT="Note "_$TR($J(G MINDX,2)," ","0")
	1729	. .... S GMT EXT=GMTEXT _": "_$P(G MTITL,U,1)
	1730	. .... S @GM DOCS@(GMTE XT)=GMNTXT
	1731	. .... Q
	1732	. ... Q
	1733	. .. D SHOWP ICK(GMDOCS ,GM0CON,.G MEXIT)
	1734	. .. Q
	1735	. . K @GMCRP T,@GMDOCS, @GMNRPT
	1736	. . Q
	1737	. Q
	1738	I GMEXIT'>0 D
	1739	. K GMTEXT S GMTEXT=" *** Done * **"
	1740	. D HANGMSG (.GMTEXT,0 ,0)
	1741	. Q
	1742	Q
	1743	;
	1744	SHOWPICK(G MROOT,GM0C ON,GMEXIT) ;
	1745	; *** Show consult & progress n otes
	1746	; *** Pick progress n ote to clo se consult
	1747	I $O(@GMROO T@(""))]"" F D Q:G MEXIT'="?"
	1748	. D SHOWNOT E(GMROOT,G M0CON)
	1749	. D PICKNOT E(GMROOT,G M0CON,.GME XIT)
	1750	. Q
	1751	Q
	1752	;
	1753	SHOWNOTE(G MROOT,GM0C ON) ;
	1754	; *** Show consult & progress n otes to us er
	1755	N GMLINE,DI R,DIROUT,D IRUT,DTOUT ,DUOUT,X,Y
	1756	D HEADER(GM 0CON,.GMLI NE)
	1757	D FOOTER(IO SL-2)
	1758	D DOCLIST^D DBR(GMROOT ,"R",GMLIN E+2,IOSL-2 )
	1759	Q
	1760	;
	1761	PICKNOTE(G MROOT,GM0C ON,GMEXIT) ;
	1762	; *** Pick progress n ote to clo se consult
	1763	N GM0NOT,GM BELL,GMGLO B,GMINDX,G MMAXX
	1764	N GMMSGS,GM TEXT,GMTIM E,GMTITL
	1765	N DIR,DIROU T,DIRUT,DT OUT,DUOUT, X,Y
	1766	; Build rea der doc li st
	1767	S DIR("A")= "Select NO TE TO CLOS E CONSULT: "
	1768	S DIR("A",1 )="Select the note t o close th e consult"
	1769	S DIR("A",2 )=" "
	1770	S DIR("A",3 )=" 0 - D o not clos e the cons ult"
	1771	S GMTITL="N ote 00: ", GMINDX=0
	1772	F S GMTITL =$O(@GMROO T@(GMTITL) ) Q:GMTITL ="" D
	1773	. ; The doc list data is a clos ed global root speci fying
	1774	. ; the loc ation of t he progres s note tex t block. The last
	1775	. ; subscri pt of data root is t he IEN of the progre ss note.
	1776	. ; @GMROOT @(Document Title) = A rrayName(. ..,Progres sNoteIEN)
	1777	. S GMGLOB= $G(@GMROOT @(GMTITL))
	1778	. S GM0NOT= $QS(GMGLOB ,$QL(GMGLO B))
	1779	. I GM0NOT> 0 D
	1780	. . S GMINDX =GMINDX+1
	1781	. . S DIR("A ",3+GMINDX )=$J(GMIND X,3)_" - " _GMTITL
	1782	. . ; IndexN umber to P rogressNot eIEN^NoteT itle mappi ng array
	1783	. . S GM0NOT (GMINDX)=G M0NOT_U_GM TITL
	1784	. . Q
	1785	. Q
	1786	S GMMAXX=GM INDX+1
	1787	S DIR("A",3 +GMINDX+1) =$J(GMMAXX ,3)_" - Re display th e consult/ progress n ote(s)"
	1788	S DIR("A",3 +GMINDX+2) =" ^ - Ex it the Con sult Closu re Tool"
	1789	S DIR("A",3 +GMINDX+3) =" "
	1790	S DIR("B")= GMMAXX
	1791	S DIR(0)="N OA^0:"_GMM AXX_":0^K: X'?1.N X"
	1792	S DIR("?")= "^D HEADER ^GMRCCD(GM 0CON)"
	1793	; Display c onsult clo sure promp t screen
	1794	D HEADER(GM 0CON)
	1795	W ! D ^DIR S GMINDX=+ $G(Y)
	1796	S GMEXIT=$S ($$DIREXIT ^GMRCCA>0: 1,GMINDX=G MMAXX:"?", 1:0)
	1797	K GMTEXT S GMTIME=3,G MBELL=0
	1798	I GMEXIT=0 D
	1799	. S GM0NOT= +$P($G(GM0 NOT(GMINDX )),U,1)
	1800	. I (GM0CON >0)&(GM0NO T>0) D
	1801	. . ; Attemp t to close consult
	1802	. . I $$CONU PDT^GMRCCC (GM0CON,GM 0NOT,.GMMS GS)>0 D
	1803	. .. S GMTEX T(1)="* The consul t has been closed *"
	1804	. .. S GMTEX T="Selecti on: "_$P(G M0NOT(GMIN DX),U,2)
	1805	. .. Q
	1806	. . E D
	1807	. .. S GMTIM E=$G(DTIME ,900),GMBE LL=1
	1808	. .. S GMTEX T(1)="* The consul t has NOT been close d *"
	1809	. .. S GMTEX T(2)="Reas on: "_$S($ G(GMMSGS)] "":GMMSGS, 1:"Unknown !")
	1810	. .. S GMTEX T(3)="Sele ction: "_$ P(GM0NOT(G MINDX),U,2 )
	1811	. .. S GMTEX T(4)=""
	1812	. .. S GMTEX T="Enter R ETURN to c ontinue: "
	1813	. .. Q
	1814	. . Q
	1815	. E D
	1816	. . S GMTEXT ="* No a ction take n on the c onsult * "
	1817	. . Q
	1818	. Q
	1819	E D
	1820	. I GMEXIT> 0 D
	1821	. . S GMTIME =0
	1822	. . S GMTEXT ="*** Exit ing the Co nsult Clos ure Tool * **"
	1823	. . Q
	1824	. Q
	1825	D HANGMSG(. GMTEXT,GMT IME,GMBELL )
	1826	Q
	1827	;
	1828	HEADER(GM0 CON,GMLINE ) ;
	1829	; *** Pt na me header
	1830	W @IOF,"Con sult closu re for pat ient: "
	1831	W $$GET1^DI Q(123,GM0C ON,.02)
	1832	W " (",$$GE T1^DIQ(123 ,GM0CON,". 02:.0905") ,") "
	1833	W $$DATE^GM RCCC($$GET 1^DIQ(123, GM0CON,".0 2:.03","I" ),"5DZ")
	1834	W !,$$GET1^ DIQ(123,GM 0CON,1)
	1835	W " (",$$GE T1^DIQ(123 ,GM0CON,"8 :.1"),") "
	1836	W $$DATE^GM RCCC($$GET 1^DIQ(123, GM0CON,3," I"),"5DZ")
	1837	S GMLINE=$Y
	1838	Q
	1839	;
	1840	FOOTER(GML INE) ;
	1841	; *** Page footer ins tructions
	1842	F Q:$Y'<(G MLINE-1) W !
	1843	W !,"Use <P F1>S to Sw itch betwe en views o f the cons ult and pr ogress not e(s)"
	1844	W !,"Use R to Return to the pre viously vi ewed consu lt or prog ress note( s)"
	1845	Q
	1846	;
	1847	HANGMSG(GM TEXT,GMTIM E,GMBELL) ;
	1848	; *** Hang a message on the scr een for a time
	1849	N DIR,DIROU T,DIRUT,DT OUT,DUOUT, X,Y
	1850	I $G(GMTEXT )]"" D
	1851	. I $G(GMBE LL)>0 S GM TEXT=GMTEX T_$C(7)
	1852	. S DIR(0)= "EA"
	1853	. M DIR("A" )=GMTEXT
	1854	. S (DIR("? "),DIR("?? "))=""
	1855	. S DIR("T" )=+$G(GMTI ME)
	1856	. D TYPEAHE D(0)
	1857	. W ! D ^DI R
	1858	. D TYPEAHE D(1)
	1859	. Q
	1860	Q
	1861	;
	1862	TYPEAHED(G MBOOL) ;
	1863	; *** Enabl e/Disable type-ahead
	1864	N GMKRNL,GM USER
	1865	I GMBOOL>0 D
	1866	. S GMUSER= $TR($$GET1 ^DIQ(200,D UZ,200.09, "I"),"YN", "10")
	1867	. S GMKRNL= $TR($$GET1 ^DIQ(8989. 3,1,209,"I "),"YN","1 0")
	1868	. I $S(GMUS ER?1N:GMUS ER,1:GMKRN L)>0 X ^%Z OSF("TYPE- AHEAD")
	1869	. Q
	1870	E D
	1871	. X ^%ZOSF( "NO-TYPE-A HEAD")
	1872	. Q
	1873	Q
	1874	;
	1875	COUNT(GMRO OT,GMPCNT, GMCCNT,GMN CNT) ;
	1876	; *** Count patients / consults / notes
	1877	N GMCONS,GM NAME,GMTIT L,GMUCON,G MUNAM,GMUT TL
	1878	S GMUNAM=$N A(@GMROOT@ ("UNIQUE-N AME"))
	1879	S GMUCON=$N A(@GMROOT@ ("UNIQUE-C ONS"))
	1880	S GMUTTL=$N A(@GMROOT@ ("UNIQUE-T ITL"))
	1881	K @GMUNAM,@ GMUCON,@GM UTTL
	1882	S (GMPCNT,G MCCNT,GMNC NT)=0
	1883	S GMNAME=""
	1884	F S GMNAME =$O(@GMROO T@("DATA", GMNAME)) Q :GMNAME="" D
	1885	. I $D(@GMU NAM@(GMNAM E))#2'>0 S GMPCNT=GM PCNT+1
	1886	. S @GMUNAM @(GMNAME)= ""
	1887	. S GMCONS= ""
	1888	. F S GMCO NS=$O(@GMR OOT@("DATA ",GMNAME,G MCONS)) Q: GMCONS="" D
	1889	. . I $D(@GM UCON@(GMCO NS))#2'>0 S GMCCNT=G MCCNT+1
	1890	. . S @GMUCO N@(GMCONS) =""
	1891	. . S GMTITL =""
	1892	. . F S GMT ITL=$O(@GM ROOT@("DAT A",GMNAME, GMCONS,GMT ITL)) Q:GM TITL="" D
	1893	. .. I $D(@G MUTTL@(GMT ITL))#2'>0 S GMNCNT= GMNCNT+1
	1894	. .. S @GMUT TL@(GMTITL )=""
	1895	. .. Q
	1896	. . Q
	1897	. Q
	1898	K @GMUNAM,@ GMUCON,@GM UTTL
	1899	Q
	1900	;
	1901	CLINLIST(G MROOT,GM0C FG) ;
	1902	; *** Get l ist of cli nics
	1903	N GM0CLN,GM 0STP,GMIND X,GMLIST,G MSCRN
	1904	S GM0CLN=0
	1905	F S GM0CLN =$O(^GMR(1 23.033,GM0 CFG,"CLIN" ,"B",GM0CL N)) Q:GM0C LN'>0 D
	1906	. S @GMROOT @("XREF-CL IN",GM0CLN )=""
	1907	. Q
	1908	S GM0STP=$$ GET1^DIQ(1 23.033,GM0 CFG,.06,"I ")
	1909	I GM0STP>0 D
	1910	. S GMLIST= $NA(^TMP(" DILIST",$J ))
	1911	. K @GMLIST
	1912	. S GMSCRN= "I $P(^(0) ,U,7)="_GM 0STP
	1913	. D LIST^DI C(44,"","@ ","Q","*", "",GM0STP, "AST",GMSC RN)
	1914	. D CLEAN^D ILF
	1915	. S GMINDX= 0
	1916	. F S GMIN DX=$O(@GML IST@(2,GMI NDX)) Q:GM INDX'>0 D
	1917	. . S GM0CLN =$G(@GMLIS T@(2,GMIND X))
	1918	. . I GM0CLN >0 S @GMRO OT@("XREF- CLIN",GM0C LN)=""
	1919	. . Q
	1920	. K @GMLIST
	1921	. Q
	1922	Q
	1923	;
	1924	CONSOKAY(G M0CON) ;
	1925	; *** Consu lt status okay?
	1926	Q $S("^c^dc ^x^"[(U_$$ GET1^DIQ(1 23,GM0CON, "8:.1")_U) :0,1:1)
	1927	;
	1928	NOTESTAT(G MSTAT) ;
	1929	; *** Get l ist of not e statuses
	1930	N GM0STA,GM INDX
	1931	K GMSTAT
	1932	F GMINDX="A MENDED","C OMPLETED" D
	1933	. S GM0STA= $$FIND1^DI C(8925.6," ","X",GMIN DX,"B")
	1934	. I GM0STA> 0 S GMSTAT (GM0STA)=G M0STA_U_GM INDX
	1935	. Q
	1936	Q
	1937	;
	1938	ISTM(GM0CF G) ;
	1939	; *** Manua l patient team assoc iated with configura tion?
	1940	Q ($$GET1^D IQ(123.033 ,GM0CFG,". 03:1","I") ="TM")
	1941	;
	1942	GLOBROOT(G MFILE,GMTR AN) ;
	1943	; *** Get f ile's glob al root
	1944	N GMROOT
	1945	S GMROOT=$$ GET1^DID(G MFILE,""," ","GLOBAL NAME")
	1946	Q $S($D(GMT RAN)#2>0:$ TR(GMROOT, U,GMTRAN), 1:GMROOT)
	1947	;
	1948	SEEN(GMSTA T) ;
	1949	; *** Pt wa s seen in clinic?
	1950	Q ("^I^NT^R ^"[(U_GMST AT_U))
	1951	;
	1952	UNSEEN(GMS TAT) ;
	1953	; *** Pt wa s not seen in clinic ?
	1954	Q ("^CC^CCR ^CP^CPR^NS ^NSR^"[(U_ GMSTAT_U))
	1955	GMRCCX (Ne w)
	1956	GMRCCX ;S FVAMC/DAD - Consult Closure To ol: Config File Util ities ;01/ 20/17 15:1 9
	1957	; ;3.0;CONSU LT/REQUEST TRACKING; 89;DEC 27, 1997; Build 16
	1958	; Consult Cl osure Tool
	1959	; IA# Usa ge Co mponent
	1960	; --------- ---------- -------
	1961	; 1058 Pri vate MD EL^DDSUTL
	1962	; 1058 Pri vate ML OAD^DDSUTL
	1963	; 2051 Sup ported LI ST^DIC
	1964	; 2052 Sup ported $$ GET1^DID
	1965	; 2053 Sup ported UP DATE^DIE
	1966	; 2054 Sup ported CL EAN^DILF
	1967	;
	1968	LOOKUP(GMX ,GM0,GMFIL E) ;
	1969	; *** Proce ss additio ns/deletio ns [-]XXX*
	1970	; Called fr om the pre -lookup tr ansform no des
	1971	; ^DD(123.0 331 -> 123 .0336,.01, 7.5)
	1972	N GMFDA,GMI EN,GMLST,D 0,D1,DA,DI C,DIERR
	1973	N DIHELP,DI MSG,DUOUT, DIRUT,DIRO UT,DO,DTOU T,X,Y
	1974	I ($G(GMX)? 1.E1"*"),( $G(GM0)>0) D
	1975	. S GMLST=$ NA(^TMP("D ILIST",$J) )
	1976	. S GMFDA=$ NA(^TMP("G MCTR-FDA", $J))
	1977	. S GMIEN=$ NA(^TMP("G MCTR-IEN", $J))
	1978	. K @GMLST, @GMFDA,@GM IEN
	1979	. I $E(GMX) ="-" D
	1980	. . D DEL(.G MX,GM0,GMF ILE)
	1981	. . Q
	1982	. E D
	1983	. . D ADD(.G MX,GM0,GMF ILE)
	1984	. . Q
	1985	. K @GMLST, @GMFDA,@GM IEN
	1986	. Q
	1987	Q
	1988	;
	1989	ADD(GMX,GM 0,GMFILE) ;
	1990	; *** Proce ss additio ns XXX* (C opy/Mod of LOOKE^XPD ET)
	1991	N GMDATA,GM IENS,GMIND X,GMPOIN,G MSCRN
	1992	S GMPOIN=$$ GET1^DID(G MFILE,.01, "","SPECIF IER")
	1993	S GMPOIN=$T R(GMPOIN,$ TR(GMPOIN, "012345678 9."))
	1994	S GMSCRN=$$ DICS(GMFIL E)
	1995	S GMX=$P(GM X,"*",1)
	1996	D LIST^DIC( GMPOIN,"", "","","*", "",GMX,"", GMSCRN)
	1997	I $G(@GMLST @(0))>0 D
	1998	. S GMINDX= 0
	1999	. F S GMIN DX=$O(@GML ST@(2,GMIN DX)) Q:GMI NDX'>0 D
	2000	. . S GMDATA =$G(@GMLST @(2,GMINDX ))
	2001	. . I GMDATA >0 D
	2002	. .. S GMIEN S="?+"_GMI NDX_","_GM 0_","
	2003	. .. S @GMFD A@(GMFILE, GMIENS,.01 )=GMDATA
	2004	. .. S @GMIE N@(GMINDX) =GMDATA
	2005	. .. Q
	2006	. . Q
	2007	. I $D(@GMF DA) D
	2008	. . D UPDATE ^DIE("",GM FDA,GMIEN)
	2009	. . I '$D(DI ERR),$D(DD S),$D(@GMI EN) D MLOA D^DDSUTL(G MIEN)
	2010	. . D CLEAN^ DILF
	2011	. . Q
	2012	. S GMX=""
	2013	. Q
	2014	E D
	2015	. K GMX
	2016	. Q
	2017	Q
	2018	;
	2019	DEL(GMX,GM 0,GMFILE) ;
	2020	; *** Proce ss deletio ns -XXX* ( Copy/Mod o f DEL^XPDE T)
	2021	N GM1,GMIEN S,GMINDX
	2022	S GMX=$P(GM X,"*",1),G MX=$E(GMX, 2,$L(GMX)- 1)
	2023	D LIST^DIC( GMFILE,"," _GM0_","," ","","*"," ",GMX)
	2024	I $G(@GMLST @(0))>0 D
	2025	. S GMINDX= 0
	2026	. F S GMIN DX=$O(@GML ST@(2,GMIN DX)) Q:GMI NDX'>0 D
	2027	. . S GM1=$G (@GMLST@(2 ,GMINDX))
	2028	. . I GM1>0 D
	2029	. .. S GMIEN S=GM1_","_ GM0_","
	2030	. .. S @GMFD A@(GMFILE, GMIENS,.01 )="@"
	2031	. .. Q
	2032	. . Q
	2033	. I $D(@GMF DA) D
	2034	. . D UPDATE ^DIE("",GM FDA)
	2035	. . I '$D(DI ERR),$D(DD S) D MDEL^ DDSUTL($NA (@GMLST@(2 )))
	2036	. . D CLEAN^ DILF
	2037	. . Q
	2038	. S GMX=""
	2039	. Q
	2040	E D
	2041	. K GMX
	2042	. Q
	2043	Q
	2044	;
	2045	DICS(GMFIL E) ;
	2046	; *** DIC(" S") data s creens
	2047	; Called fr om ADD^GMR CCX and
	2048	; ^DD(123.0 331 -> 123 .0336,.01, 0 & 12.1)
	2049	N GMSCRN
	2050	; Disabled consult se rvices are not selec table
	2051	S GMSCRN(12 3.0331)="I $P(^(0),U ,2)'=9"
	2052	; Inactive consult pr ocedures a re not sel ectable
	2053	S GMSCRN(12 3.0332)="I $P(^(0),U ,2)'>0"
	2054	; Only cons ult order items are selectable
	2055	S GMSCRN(12 3.0333)="I ($P(^(0), U,3)="""") &(^(0)?1"" GMRC""1(1" "R"",1""T" ").E)"
	2056	; Only acti ve clinica l procedur es are sel ectable
	2057	S GMSCRN(12 3.0334)="I $P(^(0),U ,9)=1"
	2058	; Only clin ics are se lectable
	2059	S GMSCRN(12 3.0335)="I $P(^(0),U ,3)=""C"""
	2060	; Only titl es are sel ectable
	2061	S GMSCRN(12 3.0336)="I $P(^(0),U ,4)=""DOC" ""
	2062	Q $G(GMSCRN (+$G(GMFIL E)),"I 1")
	2063	;
	2064	PATCH(GMOK AY) ;
	2065	; *** Check the versi on and pat ch status of GMRCT
	2066	N GMROUT,GM VERS
	2067	S GMOKAY=1
	2068	S GMROUT="E N^GMRCT"
	2069	S GMVERS=" ;;3.0;CONS ULT/REQUES T TRACKING ;1,5,11, 18,46;De c 27, 1997 ;Build 23"
	2070	I $$EN($P(G MROUT,U,2) ,$P(GMVERS ,";;",2))= "NO-MATCH" D
	2071	. S GMOKAY= 0
	2072	. W !
	2073	. W !,"The Consult Cl osure Tool uses an u ndocumente d entry po int (",GMR OUT,") to"
	2074	. W !,"dete rmine the recipients of consul t notifica tions. Th is entry p oint may"
	2075	. W !,"have changed s ince the C onsult Clo sure Tool was releas ed, see th e second"
	2076	. W !,"line of routin e ",$P(GMR OUT,U,2)," below."
	2077	. W !
	2078	. W !,"Expe cted:",GMV ERS
	2079	. W !,"Foun d: ",$T( +2^@$P(GMR OUT,U,2))
	2080	. W !
	2081	. W !,"The consult Cl osure Tool will not run until the ",GMRO UT," entry point is"
	2082	. W !,"revi ewed and t he expecte d second l ine is upd ated in PA TCH^",$T(+ 0),"."
	2083	. W !
	2084	. Q
	2085	Q
	2086	PATCHES ;/WDE/API TO CHECK F OR THE SEC OND LINE M ATCH UP ; [08/03/09 06:13am]
	2087	; ;1.0;REGIO N1;1;0 8/03/2009; Build 12;
	2088	;
	2089	; The sole i ntent of t his API is to valida te the sec ond line o f any rout ine that i s passed i n
	2090	;
	2091	; Parm 1 is the routin e WITHOUT THE ^
	2092	; parm 2 is the SECOND LINE of t he routine WITHOUT t he first t wo semi's
	2093	; See lin e tag EXAM PLE on how to run it ..
	2094	; returns EI THER MATCH OR NO-MAT CH
	2095	;
	2096	EN(PATROUT INE,PATSTR ING) ;
	2097	N PATVALID, PATTEST,PA TX,ARMVALI D
	2098	S PATVALID= "MATCH"
	2099	S PATX="S P ATTEST=$T( +2^"_PATRO UTINE_")" X PATX
	2100	S PATTEST=$ P(PATTEST, ";;",2,99)
	2101	I PATTEST'= PATSTRING S PATVALID ="NO-MATCH "
	2102	Q PATVALID
	2103	GMRCCY (Ne w)
	2104	GMRCCY ;SF VAMC/DAD - Consult C losure Too l: Date Ra nge Select or ;01/20/ 17 15:19
	2105	; ;3.0;CONSU LT/REQUEST TRACKING; 89;DEC 27, 1997; Build 16
	2106	; Consult Cl osure Tool ;
	2107	; IA# Us age C omponent
	2108	; --------- ---------- --------
	2109	; 10003 Su pported ^ %DT
	2110	; 10103 Su pported $ $FMTE^XLFD T
	2111	; 10103 Su pported $ $SCH^XLFDT
	2112	; 10104 Su pported $ $UP^XLFSTR
	2113	;
	2114	EN(GMTBEG, GMTEND,GMH EAD,GMRANG ) ; *** En try Point
	2115	; Input
	2116	; GMTBEG = Begin dat e - Defaul t (FM Int) [Req, Pas s by ref]
	2117	; GMTEND = End dat e - Defaul t (FM Int) [Req, Pas s by ref]
	2118	; GMHEAD = Header li ne [Opt, P ass by val ue]
	2119	; GMRANG = Date rang e type [Op t, Pass by value]
	2120	; M,M!,Q, Q!,S,S!,Y, Y!,F,F!,U, U! ("!" f orces sele ction)
	2121	; Output
	2122	; $$EN() = 1 - Oka y OR 0 - Exit
	2123	; GMTBEG = Begin dat e [If $$EN ()=1 FM In t Date, El se ""]
	2124	; GMTEND = End dat e [If $$EN ()=1 FM In t Date, El se ""]
	2125	;
	2126	; Example
	2127	; IF $$EN^ GMDATE(.GM TBEG,.GMTE ND,GMHEAD, GMRANG)'>0 QUIT
	2128	;
	2129	N GM,GMDATA ,GMDFLT,GM DONE,GMFRA M,GMQUIT,G MWHEN,X,Y
	2130	S (GMFRAM,G MFRAM(0))= ""
	2131	F GM=1:1 S GMDATA=$P( $T(FRAMDAT +GM),";;", 2) Q:GMDAT A=U D
	2132	. S GMFRAM= GMFRAM_U_$ $UP^XLFSTR (GMDATA)
	2133	. S GMFRAM( 0)=GMFRAM( 0)_GMDATA_ $S(GM<6:", ",1:"")
	2134	. Q
	2135	F D Q:GMQ UIT!GMDONE
	2136	. S (GMQUIT ,GMDONE)=0
	2137	. S GMTBEG= $S($G(GMTB EG)\1?7N:G MTBEG\1,1: "")
	2138	. S GMTEND= $S($G(GMTE ND)\1?7N:G MTEND\1,1: "")
	2139	. S GMDFLT= $$UP^XLFST R($G(GMRAN G))_U_GMTB EG_U_GMTEN D
	2140	. I $G(GMHE AD)]"" W ! ,GMHEAD
	2141	. W !,GMFRA M(0)
	2142	. W !,"Sele ct date ra nge: "
	2143	. W $S($TR( $P(GMDFLT, U),"!")]"" :$TR($P(GM DFLT,U),"! ")_"// ",1 :"")
	2144	. S GMWHEN= ""
	2145	. I $P(GMDF LT,U)'["!" R GMWHEN: DTIME S:'$ T GMWHEN=U
	2146	. I GMWHEN= "" S GMWHE N=$TR($P(G MDFLT,U)," !") W GMWH EN
	2147	. I (GMWHEN ="")!($E(G MWHEN)=U) S GMQUIT=1 Q
	2148	. S GMWHEN= $$UP^XLFST R(GMWHEN)
	2149	. I $F(GMFR AM,U_GMWHE N)'>0 D Q
	2150	. . D BELL(G MWHEN)
	2151	. . I $P(GMD FLT,U)["!" S GMQUIT= 1 Q
	2152	. . W !!?5," Enter the first few letters of "
	2153	. . W "one o f the choi ces listed below.",!
	2154	. . Q
	2155	. W $P($P(G MFRAM,U_GM WHEN,2),U)
	2156	. S GMWHEN= $E(GMWHEN)
	2157	. S GMQUIT= $$ASKDATE( GMWHEN,GMD FLT,.GMTBE G,.GMTEND)
	2158	. I GMQUIT D
	2159	. . S GMQUIT =$S($P(GMD FLT,U)'["! ":0,1:GMQU IT)
	2160	. . I GMQUIT '>0 W !
	2161	. . Q
	2162	. E D
	2163	. . S GMDONE =1
	2164	. . Q
	2165	. Q
	2166	S GMQUIT='$ G(GMQUIT)
	2167	I GMQUIT>0 D
	2168	. W !!,"Ran ge selecte d: "
	2169	. W $$FMTE^ XLFDT(GMTB EG,"5Z")," to ",$$FM TE^XLFDT(G MTEND,"5Z" )
	2170	. Q
	2171	E D
	2172	. S (GMTBEG ,GMTEND)=" "
	2173	. Q
	2174	Q GMQUIT
	2175	;
	2176	FRAMDAT ; ; TimeFram eName
	2177	; ;Monthly
	2178	; ;Quarterly
	2179	; ;Semi-Annu ally
	2180	; ;Yearly
	2181	; ;Fiscal Ye arly
	2182	; ;User Sele ctable
	2183	; ;^
	2184	;
	2185	ASKDATE(GM WHEN,GMDFL T,GMTBEG,G MTEND) ; * ** Prompt for date r ange
	2186	N GMQUIT
	2187	S GMQUIT=1
	2188	I GMWHEN="M " D
	2189	. S GMQUIT= $$MONTH(GM WHEN,GMDFL T,.GMTBEG, .GMTEND)
	2190	. Q
	2191	I (GMWHEN=" Q")!(GMWHE N="S") D
	2192	. S GMQUIT= $$QUART(GM WHEN,GMDFL T,.GMTBEG, .GMTEND)
	2193	. Q
	2194	I (GMWHEN=" F")!(GMWHE N="Y") D
	2195	. S GMQUIT= $$YEAR(GMW HEN,GMDFLT ,.GMTBEG,. GMTEND)
	2196	. Q
	2197	I GMWHEN="U " D
	2198	. S GMQUIT= $$USERSEL( GMWHEN,GMD FLT,.GMTBE G,.GMTEND)
	2199	. Q
	2200	Q GMQUIT
	2201	;
	2202	MONTH(GMWH EN,GMDFLT, GMTBEG,GMT END) ; *** Monthly
	2203	N %DT,GM,GM DATA,GMDON E,GMEND,GM EOM,GMMNYR ,GMMOE,GMQ UIT,GMYEAR ,X,Y
	2204	F GM=1:1 S GMDATA=$P( $T(MONTHDA T+GM),";;" ,2) Q:GMDA TA=U D
	2205	. S GMEOM($ P(GMDATA,U ))=$P(GMDA TA,U,2,3)
	2206	. Q
	2207	S (GMQUIT,G MDONE)=0
	2208	F D Q:(GM QUIT>0)!(G MDONE>0)
	2209	. K %DT
	2210	. S %DT="AE "
	2211	. S %DT("A" )="Enter M onth and Y ear: "
	2212	. I $P(GMDF LT,U,2)]"" D
	2213	. . S GMMNYR =$P(GMDFLT ,U,2)
	2214	. . S %DT("B ")=$E(GMMN YR,4,5)_"/ "_(1700+$E (GMMNYR,1, 3))
	2215	. . Q
	2216	. W ! D ^%D T S GMEND= +$G(Y)
	2217	. I GMEND'> 0 S GMQUIT =1 Q
	2218	. I ('+$E(G MEND,4,5)) !(+$E(GMEN D,6,7)) D Q
	2219	. . D BELL(" ")
	2220	. . W !!,"Pl ease enter a month a nd year"
	2221	. . W $S(+$E (GMEND,6,7 ):" only", 1:"")
	2222	. . Q
	2223	. S GMMOE=$ E(GMEND,4, 5)
	2224	. S GMTEND= $E(GMEND,1 ,5)_$P(GME OM(GMMOE), U)
	2225	. I $E(GMTE ND,4,5)="0 2" D
	2226	. . S GMYEAR =1700+$E(G MTEND,1,3)
	2227	. . S GMTEND =GMTEND+(( GMYEAR#4=0 )&((GMYEAR #100)!(GMY EAR#400=0) ))
	2228	. . Q
	2229	. S GMTBEG= $E(GMTEND, 1,5)_"01"
	2230	. S GMDONE= 1
	2231	. Q
	2232	Q GMQUIT
	2233	;
	2234	MONTHDAT ; ; MonthNum ber ^ Days InMonth ^ MonthName
	2235	; ;01^31^JAN UARY
	2236	; ;02^28^FEB RUARY
	2237	; ;03^31^MAR CH
	2238	; ;04^30^APR IL
	2239	; ;05^31^MAY
	2240	; ;06^30^JUN E
	2241	; ;07^31^JUL Y
	2242	; ;08^31^AUG UST
	2243	; ;09^30^SEP TEMBER
	2244	; ;10^31^OCT OBER
	2245	; ;11^30^NOV EMBER
	2246	; ;12^31^DEC EMBER
	2247	; ;^
	2248	;
	2249	QUART(GMWH EN,GMDFLT, GMTBEG,GMT END) ; *** Quarterly & Semi-An nually
	2250	N %DT,GM,GM DATA,GMDON E,GMMNDY,G MQU,GMQUIT ,GMQUYR,GM SBEG,GMSEM I,GMYR,GMQ ART
	2251	N GMQBEG,GM QEND,GMQQU A,X,Y
	2252	S GMSEMI=$S (GMWHEN="S ":1,1:0)
	2253	F GM=1:1 S GMDATA=$P( $T(QUARTDA T+GM),";;" ,2) Q:GMDA TA=U D
	2254	. S GMQQUA( GM)=$P(GMD ATA,U)
	2255	. S GMQBEG( GM)="000"_ $P(GMDATA, U,2)
	2256	. S GMSBEG( GM)="000"_ $P(GMDATA, U,3)
	2257	. S GMQEND( GM)="000"_ $P(GMDATA, U,4)
	2258	. Q
	2259	S GMQUYR=""
	2260	I $P(GMDFLT ,U,2)]"" D
	2261	. S GMMNDY= $E($P(GMDF LT,U,2),4, 7)
	2262	. I (GMMNDY '<GMQBEG(1 ))&(GMMNDY '>GMQEND(1 )) S GMQU= 1
	2263	. I (GMMNDY '<GMQBEG(2 ))&(GMMNDY '>GMQEND(2 )) S GMQU= 2
	2264	. I (GMMNDY '<GMQBEG(3 ))&(GMMNDY '>GMQEND(3 )) S GMQU= 3
	2265	. I (GMMNDY '<GMQBEG(4 ))&(GMMNDY '>GMQEND(4 )) S GMQU= 4
	2266	. S GMQUYR= $S(GMQU>0: GMQU_"/"_( 1700+$E($P (GMDFLT,U, 2),1,3)+(G MQU=1)),1: "")
	2267	. Q
	2268	S (GMQUIT,G MDONE)=0
	2269	F D Q:(GM QUIT>0)!(G MDONE>0)
	2270	. I GMSEMI> 0 D
	2271	. . W !!,"En ter Quarte r Period a nd FY you "
	2272	. . W "wish Semi-Annua l range to end with"
	2273	. . Q
	2274	. W !
	2275	. W !,"Ente r Quarter and Year: ",$S(GMQUY R]"":GMQUY R_"// ",1: "")
	2276	. R GMQART: DTIME S:'$ T GMQART=U
	2277	. I GMQART= "" S GMQAR T=GMQUYR
	2278	. I (GMQART =U)!(GMQAR T="") S GM QUIT=1 Q
	2279	. I (GMQART '?1N1P2N)& (GMQART'?1 N1P4N) D Q
	2280	. . D BELL(G MQART)
	2281	. . W !!,"En ter Quarte r Period i n this for mat: "
	2282	. . W "2nd q uarter 198 8 would be 2-88, 2/8 8, 2 88"
	2283	. . Q
	2284	. I ($E(GMQ ART)>4)!($ E(GMQART)< 1) D Q
	2285	. . D BELL(" ")
	2286	. . W !!,"En ter Quarte r 1 to 4 o nly"
	2287	. . Q
	2288	. S GMQU=$E (GMQART)
	2289	. S GMYR=$E (GMQART,3, 6)
	2290	. K %DT S X =GMYR D ^% DT S GMYR= $E(Y,1,3)
	2291	. F GM=1:1: 4 D
	2292	. . S GMQBEG (GM)=$S(GM =1:GMYR-1, 1:GMYR)_$E (GMQBEG(GM ),4,7)
	2293	. . S GMSBEG (GM)=$S(GM '>2:GMYR-1 ,1:GMYR)_$ E(GMSBEG(G M),4,7)
	2294	. . S GMQEND (GM)=$S(GM =1:GMYR-1, 1:GMYR)_$E (GMQEND(GM ),4,7)
	2295	. . Q
	2296	. S GMTEND= GMQEND(GMQ U)
	2297	. S GMTBEG= $S(GMSEMI: GMSBEG(GMQ U),1:GMQBE G(GMQU))
	2298	. S GMDONE= 1
	2299	. Q
	2300	Q GMQUIT
	2301	;
	2302	QUARTDAT ; ;Name ^ Qu arterStart ^ SemiSta rt ^ Quart erEnd
	2303	; ;FIRST^100 1^0701^123 1
	2304	; ;SECOND^01 01^1001^03 31
	2305	; ;THIRD^040 1^0101^063 0
	2306	; ;FOURTH^07 01^0401^09 30
	2307	; ;^
	2308	;
	2309	YEAR(GMWHE N,GMDFLT,G MTBEG,GMTE ND) ; *** Yearly & F iscal Year ly
	2310	N %DT,GMDON E,GMFY,GMQ UIT,GMYEAR ,GMYR,X,Y
	2311	S GMFY=$S(G MWHEN="F": 1,1:0)
	2312	S (GMQUIT,G MDONE)=0
	2313	F D Q:(GM QUIT>0)!(G MDONE>0)
	2314	. W !!,"Ent er ",$S(GM FY:"FISCAL ",1:"")," YEAR: "
	2315	. S GMYEAR= $S($P(GMDF LT,U,2)]"" :1700+$E($ P(GMDFLT,U ,2),1,3),1 :"")
	2316	. W $S(GMYE AR]"":GMYE AR_"// ",1 :"")
	2317	. R GMYR:DT IME S:'$T GMYR=U
	2318	. I GMYR="" S GMYR=GM YEAR
	2319	. I (GMYR=U )!(GMYR="" ) S GMQUIT =1 Q
	2320	. I (GMYR'? 2N)&(GMYR' ?4N) D Q
	2321	. . D BELL(G MYR)
	2322	. . W !!,"En ter a 2 or 4 digit " ,$S(GMFY:" fiscal ",1 :""),"year "
	2323	. . Q
	2324	. K %DT S X =GMYR D ^% DT S GMYR= $E(Y,1,3)
	2325	. I GMFY D
	2326	. . S GMTBEG =GMYR-1_"1 001"
	2327	. . S GMTEND =GMYR_"093 0"
	2328	. . Q
	2329	. E D
	2330	. . S GMTBEG =GMYR_"010 1"
	2331	. . S GMTEND =GMYR_"123 1"
	2332	. . Q
	2333	. S GMDONE= 1
	2334	. Q
	2335	Q GMQUIT
	2336	;
	2337	USERSEL(GM WHEN,GMDFL T,GMTBEG,G MTEND) ; * ** User Se lectable
	2338	N %DT,GMBEG ,GMEND,GMQ UIT,X,Y
	2339	S GMQUIT=0
	2340	W !!,"Enter beginning and endin g dates fo r the desi red time p eriod:",!
	2341	K %DT
	2342	S %DT="AEX"
	2343	S %DT("A")= "Beginning Date: "
	2344	I $P(GMDFLT ,U,2)]"" S %DT("B")= $$FMTE^XLF DT($P(GMDF LT,U,2),"5 Z")
	2345	D ^%DT S GM BEG=+$G(Y)
	2346	I GMBEG>0 D
	2347	. K %DT
	2348	. S %DT="AE X"
	2349	. S %DT(0)= GMBEG
	2350	. S %DT("A" )="Ending Date: "
	2351	. I $P(GMDF LT,U,3)]"" ,$P(GMDFLT ,U,3)'<GMB EG D
	2352	. . S %DT("B ")=$$FMTE^ XLFDT($P(G MDFLT,U,3) ,"5Z")
	2353	. . Q
	2354	. E D
	2355	. . S %DT("B ")=$$FMTE^ XLFDT(GMBE G,"5Z")
	2356	. . Q
	2357	. D ^%DT S GMEND=+$G( Y)
	2358	. I GMEND>0 D
	2359	. . S GMTBEG =GMBEG
	2360	. . S GMTEND =GMEND
	2361	. . Q
	2362	. E D
	2363	. . S GMQUIT =1
	2364	. . Q
	2365	. Q
	2366	E D
	2367	. S GMQUIT= 1
	2368	. Q
	2369	Q GMQUIT
	2370	;
	2371	BELL(X) ; *** Write ?? <Beep>
	2372	I $E(X)'="? " W " ??", $C(7)
	2373	Q
	2374	;
	2375	LASTMNTH(G MDATE,GMTB EG,GMTEND) ; *** Com pute last month date range
	2376	N GMMN,GMYR
	2377	S GMYR=1700 +$E(GMDATE ,1,3)
	2378	S GMMN=$E(G MDATE,4,5)
	2379	I (GMMN'<1) &(GMMN'>12 ) D
	2380	. S GMMN=GM MN-1
	2381	. I GMMN=0 S GMMN=12, GMYR=GMYR- 1
	2382	. I $L(GMMN )=1 S GMMN ="0"_GMMN
	2383	. S GMTBEG= (GMYR-1700 )_GMMN_"01 "
	2384	. S GMTEND= $$SCH^XLFD T("1M(1)", GMTBEG)\1
	2385	. Q
	2386	E D
	2387	. S (GMTBEG ,GMTEND)=" "
	2388	. Q
	2389	Q
	2390	GMRCZUTL ( New)
	2391	GMRCUTL1 ; SLC/DCM,JF R,MA - Gen eral Utili ties ;01/2 0/2017 15 :23
	2392	;;3 .0;CONSULT /REQUEST T RACKING; 1,4,12,15, 21,17,28,8 9;DEC 27 , 1997;Bui ld 16
	2393	;Ad ded call t o GMRCZUTL for secon dary print er
	2394	; T his routin e invokes IA #2876,3 121
	2395	; P atch #21 a dded varia ble GMRCAU DT and mov ed line ta g PRNTAUDT
	2396	; t o GMRCP5A.
	2397	;
	2398	PRNT(SRVCI FN,GMRCO) ;print for m 513 to a printer w hen new co nsult is e ntered
	2399	;;L OCAL MOD R MS/HINES 1 1-2-05 TO PRINT A SE COND COPY
	2400	N O RVP,GMRCDE V,GMRCQUED ,IOP,%ZIS, POP,ZTDTH, ZTDESC,ZTI O,ZTRTN,ZT SK,GMRCA
	2401	UDT
	2402	I ' $G(SRVCIFN ) S SRVCIF N=+$P(^GMR (123,GMRCO ,0),U,5)
	2403	Q:' $D(^GMR(12 3.5,SRVCIF N,578001)) Q:'$P(^G MR(123.5,S RVCIFN,578 001),"^")
	2404	S I OP="`"_$P( ^GMR(123.5 ,SRVCIFN,5 78001),"^" )
	2405	S % ZIS="N" D ^%ZIS I PO P S %ZIS=0 D HOME^%Z IS Q
	2406	S G MRCDEV=ION ,GMRCQUED= 1,GMRCAUDT =1
	2407	S Z TRTN="PRNT ^GMRCP5A(" _(+GMRCO)_ ","_(+$G(T IUFLG))_", 1,"""_$G(G MRCCPY,"W" )_""",0,"_ (GMRCAUDT) _")"
	2408	S Z TDESC="PRI NT SECOND COPY OF CO NSULT FORM 513 FOR N EW CONSULT
	2409	"
	2410	S Z TIO=GMRCDE V,ZTDTH=$H
	2411	D ^ %ZTLOAD
	2412	S % ZIS=0 D HO ME^%ZIS
	2413	K G MRCQUED,GM RCDEV1
	2414	Q