Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG10.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG10.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG10.m	(revision 623)
@@ -1,166 +1,166 @@
-DG10	;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 1/5/2006  21:46
-	;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-START	;
-	D LO^DGUTL
-	I $G(DGPRFLG)=1,$G(DGPLOC)=1 D  G Q:$G(DGRPOUT),A1
-	.; D EN^DGRPD,REG^IVMCQ($G(DFN))
-	. D EN^DGRPD
-	. Q:$G(DGRPOUT)
-	. ;
-	. ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
-	. ;
-	. ; HEC query call only wanted/needed for VA agency code
-	. ;
-	. I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
-	. ;
-	. ; ** end of VOE change 1 **
-	. ;
-	. D HINQ
-	;
-A	W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
-	N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
-	;
-	;MPI QUERY
-	;check to see if CIRN PD/MPI is installed
-	N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
-	K MPIFRTN
-	;
-	; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	; MPI query call only wanted/needed for VA agency code
-	;
-	I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
-	;
-	; ** end of VOE change 2 **
-	;
-	K MPIFRTN
-	;
-	I +$G(DGNEW) D
-	. ; query CMOR for Patient Record Flag Assignments if NEW patient and
-	. ; display results
-	. I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
-	;
-SKIP	;
-	S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
-	;
-	; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	; these query calls only wanted/needed for VA agency code
-	;
-	I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
-	G A1
-	;
-	; ** end of VOE change 3 **
-	;
-	;
-HINQ	;
-	S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D
-	.N DGROUT
-	.S DGROUT=X
-	.I $G(DFN) D
-	..N X,Y,DGRP
-	..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X))
-	..W !,"     Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
-	..W ?40,"   Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
-	.D @("EN^"_DGROUT) K Y Q  ;from dgdem0
-	Q
-	;
-	;   SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management 
-	;   to bypass the embossing routines when calling load/edit from IEMM
-	;
-A1	D  G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP,MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS
-	.W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data"
-	.S %=1 D YN^DICN
-	.I +$G(DGNEW) Q
-	.I $$ADD^DGADDUTL($G(DFN)) ;
-	;
-H	W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
-	G A1
-	;
-CK	S DGEDCN=1 D ^DGRPC,MT(DFN),CP
-	G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM)
-	I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR
-	;G:Y ^DGRP9
-	;
-EMBOS	;W ! D EMBOS^DGQEMA G A
-	G A
-	;
-	;
-Q	K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,VET Q
-	;
-MT(DFN)	; Check if user requires a means test.  Ask user if they want to proceedif
-	; one is required
-	I '$D(SDIEMM) DO
-	.N DGREQF,DIV
-	.D EN^DGMTR
-	.I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
-	.Q
-	I $D(SDIEMM) DO
-	.N DGMTI
-	.S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
-	.I $P(DGMTI,U,4)="R" D  I 1
-	..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^")
-	..I '$$OKTOCONT(DGMTDT) Q
-	..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC
-	.E  D WARNING
-	.Q
-	Q
-	;
-WARNING	;
-	;prints a warning to the screen about means test
-	;
-	W !!,"A means test for this encounter date was not found and may be required!"
-	W !,"Further investigation will be needed."
-	W !
-	D PAUSE
-	Q
-	;
-PAUSE	;
-	N DIR
-	S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR
-	Q
-	;
-OKTOCONT(Y)	;
-	;
-	N DIR
-	W !!,"Patient Requires a means Test"
-	X ^DD("DD")
-	W !,"Primary Means Test Required from '",Y,"'",!
-	;
-	I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO  G OKQ
-	.W !,$C(7),"You do not have the appropriate IEMM Security Key.  Contact your supervisor.",!
-	.D PAUSE
-	.S Y=0
-	;
-	S DIR("A")="Do you wish to proceed with the means test at this time"
-	S DIR("B")="YES"
-	S DIR(0)="Y"
-	D ^DIR
-OKQ	Q $S(Y=1:1,1:0)
-	;
-CP	;If not (autoexempt or MTested) & no CP test this year then
-	;prompt for add/edit cp test
-	N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
-	G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
-	S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
-	D EN^DGMTCOR
-	I +$G(DGNOCOPF) S DGMTCOR=0
-	I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
-	K DGNOCOPF
-QTCP	Q
+DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 1/5/2006  21:46
+ ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+START ;
+ D LO^DGUTL
+ I $G(DGPRFLG)=1,$G(DGPLOC)=1 D  G Q:$G(DGRPOUT),A1
+ .; D EN^DGRPD,REG^IVMCQ($G(DFN))
+ . D EN^DGRPD
+ . Q:$G(DGRPOUT)
+ . ;
+ . ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ . ;
+ . ; HEC query call only wanted/needed for VA agency code
+ . ;
+ . I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
+ . ;
+ . ; ** end of VOE change 1 **
+ . ;
+ . D HINQ
+ ;
+A W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
+ N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
+ ;
+ ;MPI QUERY
+ ;check to see if CIRN PD/MPI is installed
+ N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
+ K MPIFRTN
+ ;
+ ; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; MPI query call only wanted/needed for VA agency code
+ ;
+ I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
+ ;
+ ; ** end of VOE change 2 **
+ ;
+ K MPIFRTN
+ ;
+ I +$G(DGNEW) D
+ . ; query CMOR for Patient Record Flag Assignments if NEW patient and
+ . ; display results
+ . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
+ ;
+SKIP ;
+ S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
+ ;
+ ; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; these query calls only wanted/needed for VA agency code
+ ;
+ I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
+ G A1
+ ;
+ ; ** end of VOE change 3 **
+ ;
+ ;
+HINQ ;
+ S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D
+ .N DGROUT
+ .S DGROUT=X
+ .I $G(DFN) D
+ ..N X,Y,DGRP
+ ..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X))
+ ..W !,"     Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
+ ..W ?40,"   Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
+ .D @("EN^"_DGROUT) K Y Q  ;from dgdem0
+ Q
+ ;
+ ;   SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management 
+ ;   to bypass the embossing routines when calling load/edit from IEMM
+ ;
+A1 D  G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP,MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS
+ .W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data"
+ .S %=1 D YN^DICN
+ .I +$G(DGNEW) Q
+ .I $$ADD^DGADDUTL($G(DFN)) ;
+ ;
+H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
+ G A1
+ ;
+CK S DGEDCN=1 D ^DGRPC,MT(DFN),CP
+ G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM)
+ I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR
+ ;G:Y ^DGRP9
+ ;
+EMBOS ;W ! D EMBOS^DGQEMA G A
+ G A
+ ;
+ ;
+Q K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,VET Q
+ ;
+MT(DFN) ; Check if user requires a means test.  Ask user if they want to proceedif
+ ; one is required
+ I '$D(SDIEMM) DO
+ .N DGREQF,DIV
+ .D EN^DGMTR
+ .I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
+ .Q
+ I $D(SDIEMM) DO
+ .N DGMTI
+ .S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
+ .I $P(DGMTI,U,4)="R" D  I 1
+ ..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^")
+ ..I '$$OKTOCONT(DGMTDT) Q
+ ..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC
+ .E  D WARNING
+ .Q
+ Q
+ ;
+WARNING ;
+ ;prints a warning to the screen about means test
+ ;
+ W !!,"A means test for this encounter date was not found and may be required!"
+ W !,"Further investigation will be needed."
+ W !
+ D PAUSE
+ Q
+ ;
+PAUSE ;
+ N DIR
+ S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR
+ Q
+ ;
+OKTOCONT(Y) ;
+ ;
+ N DIR
+ W !!,"Patient Requires a means Test"
+ X ^DD("DD")
+ W !,"Primary Means Test Required from '",Y,"'",!
+ ;
+ I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO  G OKQ
+ .W !,$C(7),"You do not have the appropriate IEMM Security Key.  Contact your supervisor.",!
+ .D PAUSE
+ .S Y=0
+ ;
+ S DIR("A")="Do you wish to proceed with the means test at this time"
+ S DIR("B")="YES"
+ S DIR(0)="Y"
+ D ^DIR
+OKQ Q $S(Y=1:1,1:0)
+ ;
+CP ;If not (autoexempt or MTested) & no CP test this year then
+ ;prompt for add/edit cp test
+ N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
+ G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
+ S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
+ D EN^DGMTCOR
+ I +$G(DGNOCOPF) S DGMTCOR=0
+ I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
+ K DGNOCOPF
+QTCP Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGCV.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGCV.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGCV.m	(revision 623)
@@ -1,247 +1,203 @@
-DGCV	;ALB/DW,ERC,BRM,TMK - COMBAT VET ELIGIBILTY; 10/15/05 ; 3/24/08 7:28am
-	;;5.3;Registration;**528,576,564,673,778**; Aug 13, 1993;Build 9
-	;
-CVELIG(DFN)	;
-	;API will determine whether or not this veteran needs to have CV End
-	;Date set.  If this determination cannot be done due to imprecise
-	;or missing dates, it returns which dates need editing.
-	;Input:
-	;  DFN - Patient file IEN
-	;Output
-	;  RESULT
-	;    0 - CV End Date should not be set
-	;    1 - CV End Date should be set
-	;  If critical dates are imprecise return the following
-	;    A - CV End Date should not be set, imprecise Service Sep date
-	;    B - CV End Date should not be set, imprecise Combat To date
-	;    C - CV End Date should not be set, imprecise Yugoslavia To date
-	;    D - CV End Date should not be set, imprecise Somalia To date
-	;    E - CV End Date should not be set, imprecise Pers Gulf To date
-	;  If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
-	;    OEF/OIF records on file, return the following so that it  will
-	;    appear on the Imprecise/Missing Date Report
-	;    F - missing Service Sep Date & no OEF OIF or OEF/OIF Unknown dates
-	;  If critical dates are missing but the corresponding indicator fields
-	;    are set to 'YES' return the following
-	;    G - missing Combat To Date, but Combat Indicated? = 'Yes'
-	;    H - missing PG To Date, but PG Indicated? = 'Yes'
-	;    I - missing Somalia To Date, but Somalia Indicator = 'Yes'
-	;    J - missing Yugoslavia To Date, but Yugoslavia Indicator = 'Yes'
-	;
-	N DG1,DG2,I,RESULT
-	N DGCOM,DGCVDT,DGCVFLG,DGGULF,DGSOM,DGSRV,DGYUG,DGOEIF
-	S (DG1,DG2,RESULT)=0
-	I $G(DFN)']"" Q RESULT
-	I '$D(^DPT(DFN)) Q RESULT
-	;
-	;get combat related data from top-level VistA fields
-	N DGARR,DGERR
-	D GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294;.5295","I","DGARR","DGERR")
-	D PARSE
-	;
-	S DG1=$$CHKSSD(DFN) ;check SSD for imprecise or missing
-	S DGDATE=$G(DGCOM)_"^"_$G(DGYUG)_"^"_$G(DGSOM)_"^"_$G(DGGULF)_"^"_$G(DGOEIF)
-	;
-	I $S(DG1="F":1,1:$P(DGDATE,U,5)>$G(DGSRV)) D
-	. ; Use OIF/OEF/UNKNOWN OEF/OIF to dt only when SSD missing or SSD less
-	. ; than OIF/OEF/UNKNOWN OEF/OIF to dt
-	. N DGSRV,Z
-	. S DGSRV=$P(DGDATE,U,5),Z=$$CHKSSD(DFN)
-	. I Z=1 S DG1=Z
-	;
-	S DG2=$$CHKREST(DGDATE,$G(DGSRV)) ;check other "TO" dates for imprecise, missing or invalid
-	S RESULT=$$RES(DG1,$G(DG2))
-	Q RESULT
-	;
-RES(DG1,DG2)	;determine the final RESULT code from DG1 & DG2
-	;if SSD evaluates to earlier than 11/11/98, can't set CV End Date
-	I DG1=0!($G(DG2)=0) Q 0
-	;if SSD is 1
-	I DG1=1,($G(DG2)=1!($G(DG2)']"")) Q 1
-	I DG1=1,($G(DG2)=0) Q 0
-	I DG1=1 Q DG2
-	;if SSD is imprecise or missing
-	I DG1'=1,($G(DG2)=1) S DG2=""
-	Q DG1_DG2
-	;
-CHKDATE(DGDATE,I,SSD)	;check to see if date is imprecise or missing
-	;if imprecise check to see if the imprecision prevents CV evaluation
-	;if not imprecise check to see if after 11/11/98
-	; Note that SSD doesn't appear to ever be used here (TMK)
-	N RES
-	S RES=0
-	I $G(DGDATE)']"",I'=5 D  Q RES
-	. S RES=$S(I=0:"F",I=1:"G",I=2:"H",I=3:"I",I=4:"J",1:"")
-	I $E(DGDATE,6,7)="00" D
-	. I I=0 I DGDATE>2981111 S RES="A" Q
-	. I DGDATE=2980000!(DGDATE=2981100) D  Q
-	.. ; Note OIF/OEF/UNKNOWN OEF/OIF will not get here as these dates by
-	.. ; definition are after 11/11/98
-	. . S RES=$S(I=0:"A",I=1:"B",I=2:"C",I=3:"D",I=4:"E",1:"")
-	Q:RES="A" RES
-	I DGDATE>2981111 S RES=1
-	Q RES
-	;
-SETCV(DFN,DGSRV)	;calculate CV end date
-	;    DGSRV is the most recent of the Service Separation Date 
-	;    or the OEF/OIF To Date, called from file #2 new style 
-	;    cross reference "ACVCOM"
-	N DGCVEDT,DGFDA,DGNDAA,DGPLUS3,DGTMPDT,DGYRS
-	S DGNDAA=3080128
-	I $G(DFN)']""!($G(DGSRV)']"") Q
-	I '$D(^DPT(DFN)) Q
-	I $$GET1^DIQ(2,DFN_",",.5295,"I") Q
-	D CVRULES(DFN,DGSRV,.DGYRS)
-	Q:$G(DGYRS)'=3&($G(DGYRS)'=5)
-	;NDAA legislation, enacted 1/28/08, gives vets discharged
-	;on or after 1/28/03 (2 years previously) CV Eligibility 
-	;for 5 years.  Vets discharged before 1/28/03 get eligibility 
-	;for 3 years after enactment (or until 1/27/2011) DG*5.3*778
-	S DGTMPDT=$S(DGYRS=3:DGNDAA,1:DGSRV)
-	S DGCVEDT=($E(DGTMPDT,1,3)+DGYRS)_$E(DGTMPDT,4,7)
-	S DGCVEDT=$$FMADD^XLFDT(DGCVEDT,-1)
-	S DGFDA(2,DFN_",",.5295)=DGCVEDT
-	D FILE^DIE(,"DGFDA")
-	Q
-	;
-CVRULES(DFN,DGSRV,DGYRS)	;apply rules for the CV End Date
-	;extension project - DG*5.3*778
-	;DGSRV - most recent of Service Sep Date or OEIUUF to date
-	;   DGYRS = 3 years from NDAA or 1/27/2011
-	;         = 5 years from SSD or Enrollment App Date
-	;determine how many years extra CV eligibility to give
-	N DGCIEN,DGCUTOFF,DGENRDT,DGPIEN,DGPRI,DGQT,DGSTAT
-	;determine if veteran has an enrollment record prior
-	;to 1/28/2008 (the NDAA date) and no CV End Date for
-	;this enrollment
-	S DGYRS=5
-	S (DGPRI,DGQT)=0
-	S DGCUTOFF=3030128
-	S DGCIEN=$$FINDCUR^DGENA(DFN)
-	I $G(DGCIEN),($D(^DGEN(27.11,DGCIEN,0)))]"" D
-	. S DGENRDT=$$GET1^DIQ(27.11,DGCIEN_",",75.01,"I") Q:$G(DGENRDT)']""
-	. I $P(DGENRDT,".",1)<DGNDAA S DGPRI=1 Q
-	. I DGENRDT'<DGNDAA D
-	. . S DGPIEN=DGCIEN
-	. . F  S DGPIEN=$$FINDPRI^DGENA(DGPIEN) Q:'DGPIEN  D  Q:DGQT
-	. . . S DGENRDT=$$GET1^DIQ(27.11,DGPIEN_",",75.01,"I")
-	. . . Q:$G(DGENRDT)']""
-	. . . I $P(DGENRDT,".",1)<DGNDAA S (DGPRI,DGQT)=1
-	;if DGPRI=1, then there is an enrollment prior to 1/28/08
-	I DGPRI=1 D  Q
-	. I $G(DGCIEN)]"" S DGSTAT=$$GET1^DIQ(27.11,DGCIEN_",",.04,"E")
-	. I $G(DGSTAT)["INITIAL APPLICATION BY VAMC"!($G(DGSTAT)["BELOW ENROLLMENT GROUP THRESHOLD") D
-	. . I DGSRV<DGCUTOFF S DGYRS=3
-	;
-	;if no enrollment prior to 1/28/08 (DGPRI=0) check service date
-	;against cutoff date - 1/28/03
-	I DGSRV<DGCUTOFF S DGYRS=3
-	Q
-	;
-CVEDT(DFN,DGDT)	;Provide Combat Vet Eligibility End Date, if eligible
-	;Supported DBIA #4156
-	;Input:  DFN - Patient file IEN
-	;        DGDT - Treatment date (optional), 
-	;               DT is default
-	;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
-	;               Eligible on DGDT(1,0)^is patient eligible on input date?
-	;      (piece 1)  1 - qualifies as a CV
-	;                 0 - does not qualify as a CV
-	;                -1 - bad DFN or date
-	;      (piece 3)  1 - vet was eligible on date specified (or DT)      
-	;                 0 - vet was not eligible on date specified (or DT)
-	;
-	N RESULT
-	S RESULT=""
-	I $G(DFN)="" Q -1
-	I '$D(^DPT(DFN)) Q -1
-	;if time sent in, drop time
-	I $G(DGDT)']"" S DGDT=DT
-	I DGDT?7N1"."1.6N S DGDT=$E(DGDT,1,7)
-	I DGDT'?7N Q -1
-	S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
-	I $G(RESULT)']"" Q 0
-	S RESULT=$S(DGDT'>RESULT:RESULT_"^1",1:RESULT_"^0") ; if treatment date is earlier or equal to end date, veteran is eligible
-	S RESULT=$S($G(RESULT):1_"^"_RESULT,1:0)
-	Q RESULT
-	;
-PARSE	;GETS^DIQ called in CVELIG - in this subroutine stuff results into array
-	S DGSRV=$G(DGARR(2,DFN_",",.327,"I"))
-	S DGCOM=$G(DGARR(2,DFN_",",.5294,"I")) ;Combat To Date
-	S DGGULF=$G(DGARR(2,DFN_",",.322012,"I")) ;Persian Gulf To Date
-	S DGSOM=$G(DGARR(2,DFN_",",.322018,"I")) ;Somalia To Date
-	S DGYUG=$G(DGARR(2,DFN_",",.322021,"I")) ;Yugoslavia To Date
-	S DGCVDT=$G(DGARR(2,DFN_",",.5295,"I")) ;CV End Date
-	; get last OIF/OEF/UNKNOWN OEF/OIF episode from multiple
-	S DGOEIF=$P($$LAST^DGENOEIF(DFN),U)
-	Q
-	;
-CHKSSD(DFN)	;check the Serv Sep Date [Last]
-	; DGSRV=last SSD
-	;  Output - RESULT
-	;    1 - Date is present and after 11/11/1998
-	;    0 - Date is present but before 11/11/1998
-	;    A - Date is imprecise & either is or potentially is after 11/11/98
-	;    F - Date is missing
-	N DG1
-	I $G(DGSRV)']"" Q "F"
-	S DG1=$$CHKDATE(DGSRV,0)
-	I $G(DG1)']"" S DG1=0
-	Q DG1
-	;
-CHKREST(DGDATE,SSD)	;
-	; SSD = optional, = to the last serv sep date
-	N DG3,DG4,DGDT,DGFLG,DGLEN,DGQ,DGR,DGRES,DGX
-	S (DG3,DG4,DGR,DGRES)=""
-	S DGQ=0 ;loop terminator
-	S DGFLG=0 ;flag to indicate that one of the dates is missing (no 
-	;          need to check this for OIF/OEF/UNKNOWN OEF/OIF since
-	;          by definition, these must always be post 11/11/98)
-	F DGX=1:1:5 D
-	. S DGDT=$P(DGDATE,U,DGX) D
-	. . I DGX'=5,$G(DGDT)']"" S DGFLG=1
-	. . S DG4=$$CHKDATE(DGDT,DGX,$G(SSD))
-	. . I $G(DG4)'=0 S DG3=$G(DG3)_$G(DG4)
-	S DGLEN=$L(DG3)
-	S DGQ=0
-	F DGX=1:1:DGLEN S DGCHAR=$E(DG3,DGX) D  Q:DGQ=1
-	. I DGCHAR=1 S DG3=DGCHAR,DGQ=1 Q
-	. I "BCDE"[DGCHAR S DGR=DGR_DGCHAR,DGQ=2
-	I DGQ=1 Q 1
-	I DGQ=2 Q $E(DGR)
-	I DGFLG=1 S DGRES=$$MISS(DFN,DGLEN,DG3)
-	Q DGRES
-	;
-MISS(DFN,DGLEN,DGRES)	;there is at least one missing date, and in order to 
-	;return a RESULT of a missing date, need to check to see if the 
-	;corresponding indicator field is set to 'YES'
-	N DGARR,DGCHAR,DGERR,DGQ,DGR,DGX
-	N DGCIND,DGPGIND,DGSIND,DGYIND
-	S (DGCHAR,DGQ,DGR)=0
-	D GETS^DIQ(2,DFN_",",".32201;.322019;.322016;.5291","I","DGARR","DGERR")
-	S DGCIND=$G(DGARR(2,DFN_",",.5291,"I")) ;Combat Service Indicated
-	S DGYIND=$G(DGARR(2,DFN_",",.322019,"I")) ;Yugo service indicated
-	S DGSIND=$G(DGARR(2,DFN_",",.322016,"I")) ;Somalia service indicated
-	S DGPGIND=$G(DGARR(2,DFN_",",.32201,"I")) ;Pers Gulf service indicated
-	F DGX=1:1:DGLEN S DGCHAR=$E(DGRES,DGX) D  Q:DGQ=1
-	. I DGCHAR="G",($G(DGCIND)="Y") S DGR="G",DGQ=1 Q
-	. I DGCHAR="H",($G(DGYIND)="Y") S DGR="H",DGQ=1 Q
-	. I DGCHAR="I",($G(DGSIND)="Y") S DGR="I",DGQ=1 Q
-	. I DGCHAR="J",($G(DGPGIND)="Y") S DGR="J"
-	Q DGR
-DELCV(DFN)	;called by the Kill logic of the ACVCOM cross reference
-	;if $$CVELIG^DGCV returns a 0 the CV End Date should be deleted
-	;because this would indicate that fields have been changed and
-	;CV eligibility is no longer appropriate
-	;
-	N DGCV,DGFDA
-	K DGCVFLG
-	S DGCVFLG=0
-	I $G(DFN)']"" Q
-	I '$D(^DPT(DFN)) Q
-	S DGCV=$$GET1^DIQ(2,DFN_",",.5295,"I")
-	I $G(DGCV)']"" Q
-	S DGCVFLG=1
-	S DGFDA(2,DFN_",",.5295)="@"
-	D FILE^DIE(,"DGFDA")
-	Q
+DGCV ;ALB/DW,ERC,BRM,TMK - COMBAT VET ELIGIBILTY; 10/15/05
+ ;;5.3;Registration;**528,576,564,673**; Aug 13, 1993
+ ;
+CVELIG(DFN) ;
+ ;API will determine whether or not this vetearn needs to have CV End
+ ;Date set.  If this determination cannot be done due to imprecise
+ ;or missing dates, it returns which dates need editing.
+ ;Input:
+ ;  DFN - Patient file IEN
+ ;Output
+ ;  RESULT
+ ;    0 - CV End Date should not be updated
+ ;    1 - CV End Date should be updated
+ ;  If critical dates are imprecise return the following
+ ;    A - CV End Date should not be updated, imprecise Service Sep date
+ ;    B - CV End Date should not be updated, imprecise Combat To date
+ ;    C - CV End Date should not be updated, imprecise Yugoslavia To date
+ ;    D - CV End Date should not be updated, imprecise Somalia To date
+ ;    E - CV End Date should not be updated, imprecise Pers Gulf To date
+ ;  If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
+ ;    OEF/OIF records on file, return the following so that it  will
+ ;    appear on the Imprecise/Missing Date Report
+ ;    F - missing Service Sep Date & no OEF OIF or OEF/OIF Unknown dates
+ ;  If critical dates are missing but the corresponding indicator fields
+ ;    are set to 'YES' return the following
+ ;    G - missing Combat To Date, but Combat Indicated? = 'Yes'
+ ;    H - missing PG To Date, but PG Indicated? = 'Yes'
+ ;    I - missing Somalia To Date, but Somalia Indicator = 'Yes'
+ ;    J - missing Yugoslavia To Date, but Yugoslavia Indicator = 'Yes'
+ ;
+ N DG1,DG2,I,RESULT
+ N DGCOM,DGCVDT,DGCVFLG,DGGULF,DGSOM,DGSRV,DGYUG,DGOEIF
+ S (DG1,DG2,RESULT)=0
+ I $G(DFN)']"" Q RESULT
+ I '$D(^DPT(DFN)) Q RESULT
+ ;
+ ;get combat related data from top-level VistA fields
+ N DGARR,DGERR
+ D GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294;.5295","I","DGARR","DGERR")
+ D PARSE
+ ;
+ S DG1=$$CHKSSD(DFN) ;check SSD for imprecise or missing
+ S DGDATE=$G(DGCOM)_"^"_$G(DGYUG)_"^"_$G(DGSOM)_"^"_$G(DGGULF)_"^"_$G(DGOEIF)
+ ;
+ I $S(DG1="F":1,1:$P(DGDATE,U,5)>$G(DGSRV)) D
+ . ; Use OIF/OEF/UNKNOWN OEF/OIF to dt only when SSD missing or SSD less
+ . ; than OIF/OEF/UNKNOWN OEF/OIF to dt
+ . N DGSRV,Z
+ . S DGSRV=$P(DGDATE,U,5),Z=$$CHKSSD(DFN)
+ . I Z=1 S DG1=Z
+ ;
+ S DG2=$$CHKREST(DGDATE,$G(DGSRV)) ;check other "TO" dates for imprecise, missing or invalid
+ S RESULT=$$RES(DG1,$G(DG2))
+ Q RESULT
+ ;
+RES(DG1,DG2) ;determine the final RESULT code from DG1 & DG2
+ ;if SSD evaluates to earlier than 11/11/98, can't set CV End Date
+ I DG1=0!($G(DG2)=0) Q 0
+ ;if SSD is 1
+ I DG1=1,($G(DG2)=1!($G(DG2)']"")) Q 1
+ I DG1=1,($G(DG2)=0) Q 0
+ I DG1=1 Q DG2
+ ;if SSD is imprecise or missing
+ I DG1'=1,($G(DG2)=1) S DG2=""
+ Q DG1_DG2
+ ;
+CHKDATE(DGDATE,I,SSD) ;check to see if date is imprecise or missing
+ ;if imprecise check to see if the imprecision prevents CV evaluation
+ ;if not imprecise check to see if after 11/11/98
+ ; Note that SSD doesn't appear to ever be used here (TMK)
+ N RES
+ S RES=0
+ I $G(DGDATE)']"",I'=5 D  Q RES
+ . S RES=$S(I=0:"F",I=1:"G",I=2:"H",I=3:"I",I=4:"J",1:"")
+ I $E(DGDATE,6,7)="00" D
+ . I I=0 I DGDATE>2981111 S RES="A" Q
+ . I DGDATE=2980000!(DGDATE=2981100) D  Q
+ .. ; Note OIF/OEF/UNKNOWN OEF/OIF will not get here as these dates by
+ .. ; definition are after 11/11/98
+ . . S RES=$S(I=0:"A",I=1:"B",I=2:"C",I=3:"D",I=4:"E",1:"")
+ Q:RES="A" RES
+ I DGDATE>2981111 S RES=1
+ Q RES
+ ;
+SETCV(DFN,DGSRV) ;calculate CV end date
+ K DGCVEDT
+ N DGFDA
+ I $G(DFN)']""!($G(DGSRV)']"") Q
+ I '$D(^DPT(DFN)) Q
+ S DGCVEDT=$P($$SCH^XLFDT("24M",DGSRV),".")
+ I DGCVEDT=$G(DGCVDT) Q
+ I $$GET1^DIQ(2,DFN_",",.5295,"I") Q
+ S DGFDA(2,DFN_",",.5295)=DGCVEDT
+ D FILE^DIE(,"DGFDA")
+ Q
+ ;
+CVEDT(DFN,DGDT) ;Provide Combat Vet Eligibility End Date, if eligible
+ ;Supported DBIA #4156
+ ;Input:  DFN - Patient file IEN
+ ;        DGDT - Treatment date (optional), 
+ ;               DT is default
+ ;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
+ ;               Eligible on DGDT(1,0)^is patient eligible on input date?
+ ;      (piece 1)  1 - qualifies as a CV
+ ;                 0 - does not qualify as a CV
+ ;                -1 - bad DFN or date
+ ;      (piece 3)  1 - vet was eligible on date specified (or DT)      
+ ;                 0 - vet was not eligible on date specified (or DT)
+ ;
+ N RESULT
+ S RESULT=""
+ I $G(DFN)="" Q -1
+ I '$D(^DPT(DFN)) Q -1
+ ;if time sent in, drop time
+ I $G(DGDT)']"" S DGDT=DT
+ I DGDT?7N1"."1.6N S DGDT=$E(DGDT,1,7)
+ I DGDT'?7N Q -1
+ S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
+ I $G(RESULT)']"" Q 0
+ S RESULT=$S(DGDT'>RESULT:RESULT_"^1",1:RESULT_"^0") ; if treatment date is earlier or equal to end date, veteran is eligible
+ S RESULT=$S($G(RESULT):1_"^"_RESULT,1:0)
+ Q RESULT
+ ;
+PARSE ;GETS^DIQ called in CVELIG - in this subroutine stuff results into array
+ S DGSRV=$G(DGARR(2,DFN_",",.327,"I"))
+ S DGCOM=$G(DGARR(2,DFN_",",.5294,"I")) ;Combat To Date
+ S DGGULF=$G(DGARR(2,DFN_",",.322012,"I")) ;Persian Gulf To Date
+ S DGSOM=$G(DGARR(2,DFN_",",.322018,"I")) ;Somalia To Date
+ S DGYUG=$G(DGARR(2,DFN_",",.322021,"I")) ;Yugoslavia To Date
+ S DGCVDT=$G(DGARR(2,DFN_",",.5295,"I")) ;CV End Date
+ ; get last OIF/OEF/UNKNOWN OEF/OIF episode from multiple
+ S DGOEIF=$P($$LAST^DGENOEIF(DFN),U)
+ Q
+ ;
+CHKSSD(DFN) ;check the Serv Sep Date [Last]
+ ; DGSRV=last SSD
+ ;  Output - RESULT
+ ;    1 - Date is present and after 11/11/1998
+ ;    0 - Date is present but before 11/11/1998
+ ;    A - Date is imprecise & either is or potentially is after 11/11/98
+ ;    F - Date is missing
+ N DG1
+ I $G(DGSRV)']"" Q "F"
+ S DG1=$$CHKDATE(DGSRV,0)
+ I $G(DG1)']"" S DG1=0
+ Q DG1
+ ;
+CHKREST(DGDATE,SSD) ;
+ ; SSD = optional, = to the last serv sep date
+ N DG3,DG4,DGDT,DGFLG,DGLEN,DGQ,DGR,DGRES,DGX
+ S (DG3,DG4,DGR,DGRES)=""
+ S DGQ=0 ;loop terminator
+ S DGFLG=0 ;flag to indicate that one of the dates is missing (no 
+ ;          need to check this for OIF/OEF/UNKNOWN OEF/OIF since
+ ;          by definition, these must always be post 11/11/98)
+ F DGX=1:1:5 D
+ . S DGDT=$P(DGDATE,U,DGX) D
+ . . I DGX'=5,$G(DGDT)']"" S DGFLG=1
+ . . S DG4=$$CHKDATE(DGDT,DGX,$G(SSD))
+ . . I $G(DG4)'=0 S DG3=$G(DG3)_$G(DG4)
+ S DGLEN=$L(DG3)
+ S DGQ=0
+ F DGX=1:1:DGLEN S DGCHAR=$E(DG3,DGX) D  Q:DGQ=1
+ . I DGCHAR=1 S DG3=DGCHAR,DGQ=1 Q
+ . I "BCDE"[DGCHAR S DGR=DGR_DGCHAR,DGQ=2
+ I DGQ=1 Q 1
+ I DGQ=2 Q $E(DGR)
+ I DGFLG=1 S DGRES=$$MISS(DFN,DGLEN,DG3)
+ Q DGRES
+ ;
+MISS(DFN,DGLEN,DGRES) ;there is at least one missing date, and in order to 
+ ;return a RESULT of a missing date, need to check to see if the 
+ ;corresponding indicator field is set to 'YES'
+ N DGARR,DGCHAR,DGERR,DGQ,DGR,DGX
+ N DGCIND,DGPGIND,DGSIND,DGYIND
+ S (DGCHAR,DGQ,DGR)=0
+ D GETS^DIQ(2,DFN_",",".32201;.322019;.322016;.5291","I","DGARR","DGERR")
+ S DGCIND=$G(DGARR(2,DFN_",",.5291,"I")) ;Combat Service Indicated
+ S DGYIND=$G(DGARR(2,DFN_",",.322019,"I")) ;Yugo service indicated
+ S DGSIND=$G(DGARR(2,DFN_",",.322016,"I")) ;Somalia service indicated
+ S DGPGIND=$G(DGARR(2,DFN_",",.32201,"I")) ;Pers Gulf service indicated
+ F DGX=1:1:DGLEN S DGCHAR=$E(DGRES,DGX) D  Q:DGQ=1
+ . I DGCHAR="G",($G(DGCIND)="Y") S DGR="G",DGQ=1 Q
+ . I DGCHAR="H",($G(DGYIND)="Y") S DGR="H",DGQ=1 Q
+ . I DGCHAR="I",($G(DGSIND)="Y") S DGR="I",DGQ=1 Q
+ . I DGCHAR="J",($G(DGPGIND)="Y") S DGR="J"
+ Q DGR
+DELCV(DFN) ;called by the Kill logic of the ACVCOM cross reference
+ ;if $$CVELIG^DGCV returns a 0 the CV End Date should be deleted
+ ;because this would indicate that fields have been changed and
+ ;CV eligibility is no longer appropriate
+ ;
+ N DGCV,DGFDA
+ K DGCVFLG
+ S DGCVFLG=0
+ I $G(DFN)']"" Q
+ I '$D(^DPT(DFN)) Q
+ S DGCV=$$GET1^DIQ(2,DFN_",",.5295,"I")
+ I $G(DGCV)']"" Q
+ S DGCVFLG=1
+ S DGFDA(2,DFN_",",.5295)="@"
+ D FILE^DIE(,"DGFDA")
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEATH.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEATH.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEATH.m	(revision 623)
@@ -1,157 +1,144 @@
-DGDEATH	;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 10/27/04 9:45pm
-	;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725,772**;Aug 13, 1993;Build 4
-	;
-GET	N DGMTI,DATA
-	S DGDTHEN="" W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S (DA,DFN)=+Y
-	S DGDOLD=$G(^DPT(DFN,.35))
-	I $D(^DPT(DFN,.1)) W !?3,"Patient is currently in-house.  Discharge him with a discharge type of DEATH." G GET
-	I $S($D(^DPT(DFN,.35)):^(.35),1:"") F DGY=0:0 S DGY=$O(^DGPM("ATID1",DFN,DGY)) Q:'DGY  S DGDA=$O(^(DGY,0)) I $D(^DGPM(+DGDA,0)),$P(^(0),"^",17)]"" S DGXX=$P(^(0),"^",17),DGXX=^DGPM(DGXX,0) I "^12^38^"[("^"_$P(DGXX,"^",18)_"^") G DIS
-	D NOW^%DTC S DGNOW=%
-	S ^TMP("DEATH",$J)=1
-	K A W ! S DIE=DIC,DR=".351" D ^DIE
-	I '$D(^DPT(DFN,.35)) K ^TMP("DEATH",$J) G GET
-	S DGDNEW=^DPT(DFN,.35)
-	I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE
-	I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET
-SN	I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE I $P($G(^DPT(DFN,.35)),"^",3)']"" D SNDISP G SN
-	I DGDOLD'=DGDNEW D DISCHRGE
-	I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR
-	K ^TMP("DEATH",$J) G GET
-	;
-DIS	W !,"Patient has a discharge type of Death",!,"Edit the discharge",!
-Q	K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN,DGDOLD,DGDNEW,DGDONOT Q
-XFR	; called from set x-ref of field .351 of file 2
-	N DGPCMM,DGFAPT,DGFAPTI,DGFAPT1
-	Q:'$D(DFN)
-	K DGTEXT D ^DGPATV S DGDEATH=$$GET1^DIQ(2,DFN,.351,"I"),XMSUB="PATIENT HAS EXPIRED",DGCT=0
-	D DEMOG
-	S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGPMSTAT
-	S Y=$$FMTE^XLFDT(Y),Y=$S(Y]"":Y,1:"UNKNOWN")
-	S DGDONOT=0 D APTT3
-	D LINE("")
-	D LINE("      Date/Time of Death: "_DEATHVAL_$S(DGDONOT:"",'DG1:"",$D(DGDTHEN):"",1:"  (While an inpatient)"))
-	D LINE("")
-	I '$D(ADM),DG1,$D(^DGPM(+DGA1,0)) S ADM=+^DGPM($P(^(0),"^",14),0)
-	S Y=$$FMTE^XLFDT($S($D(ADM):ADM,1:""))
-	D LINE($S($D(DGDTHEN):"",DG1:"     Admission Date/Time: "_Y_$S((DGDDT-ADM)<1:"  (Within 24 hours of hospitalization)",1:""),1:""))
-	D LINE("")
-	S DGX=$P($G(^DGPM(+$G(DGA1),0)),"^",6),DGX=$P($G(^DIC(42,+DGX,0)),U,1)
-	D LINE($S($D(DGDTHEN):"",('DG1):"",$D(DGA1):"             Admitted To: "_$S(DGX]"":DGX,1:"UNKNOWN"),1:"")) K DGX
-	D LINE("")
-	I DG1&'$D(DGDTHEN) D 
-	. D LINE($S($D(DGXFR0):"           Last Transfer: "_$S($D(^DIC(42,+$P(DGXFR0,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN"),1:""))
-	. D LINE("")
-F	N DGARRAY,SDCNT S DGFAPT=DGDEATH,DGFAPTI=""
-	S DGARRAY("FLDS")=3,DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY(1)=DT,DGARRAY(3)="I;R"
-	S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
-	;
-	I SDCNT>0 F  S DGFAPT=$O(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:'DGFAPT  S DGFAPT1=$G(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:DGFAPT1']""  D  Q:DGFAPTI
-	.I $P($P(DGFAPT1,U,3),";")'["C" D LINE("NOTE: Patient has future appointments scheduled!!") S DGFAPTI=1
-	S DGSCHAD=0 D SA I DGSCHAD D LINE("NOTE: Patient had scheduled admissions which have been cancelled!!")
-	I 'DGVETS D LINE("Patient is a NON-VETERAN."_$S($D(^DIC(21,+$P($G(^DPT(DFN,.32)),"^",3),0)):"  ["_$P(^(0),"^",1)_"]",1:""))
-	S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
-	S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
-Q1	S DGB=1 D ^DGBUL S X=DGDEATH
-	K DGDEATH,DGSCHAD,DGI,Y,DGDDT,^TMP($J,"SDAMA301") D KILL^DGPATV K ADM,DG1,DGA1,DGCT,DGT,DGXX,DGY,Z Q
-SA	F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI  I $D(^DGS(41.1,DGI,0)),($P(^(0),"^",13)']""),($P(^(0),"^",17)']"") S $P(^(0),"^",13)=DGDEATH,$P(^(0),"^",14)=+DUZ,$P(^(0),"^",15)=1,$P(^(0),"^",16)=2,DGSCHAD=1
-	Q
-	;
-DEL	; delete death bulletin
-	N DGPCMM,DELBY,DELTM,DTHINFO
-	S DFN=+$G(DA) I '$D(^DPT(DFN,0)) Q  ; no patient node
-	I +$G(^DPT(DFN,.35)) Q  ; not deletion
-	S DGDEATH=X,XMSUB="Patient Death has been Deleted",DGCT=0
-	D ^DGPATV
-	D LINE("The date of death for the following patient has been deleted.")
-	D LINE("")
-	D DEMOG
-	D LINE("")
-	S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
-	S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
-	S DGB=1 D ^DGBUL S X=DGDEATH
-	K DGCT,DGDEATH D KILL^DGPATV
-	Q
-	;
-DEMOG	; list main demographics
-	D LINE("                    NAME: "_DGNAME)
-	D LINE("                     SSN: "_$P(SSN,"^",2))
-	D LINE("                     DOB: "_$P(DOB,"^",2))
-	I DGVETS D
-	. N DGX
-	. S DGX=$G(^DPT(DFN,.31))
-	. S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGX,U,4)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
-	. D LINE("   CLAIM FOLDER LOCATION: "_$S($D(DGLOCATN):DGLOCATN,1:"NOT LISTED"))
-	. D LINE("            CLAIM NUMBER: "_$S($P(DGX,"^",3)]"":$P(DGX,"^",3),1:"NOT LISTED"))
-	D LINE("   COORDINATING MASTER OF RECORD: "_DGCMOR)
-	D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","DTHINFO")
-	S DEATHVAL=$G(DTHINFO(2,DFN_",",.351,"E"))
-	S DEATHVAL=$$FMTE^XLFDT(DEATHVAL),DEATHVAL=$S(DEATHVAL]"":DEATHVAL,1:"UNKNOWN")
-	S SOURCE=$G(DTHINFO(2,DFN_",",.353,"E"))
-	S DELTM=$G(DTHINFO(2,DFN_",",.354,"E"))
-	S DELBY=$G(DTHINFO(2,DFN_",",.355,"E"))
-	D LINE("")
-	D LINE("             LAST EDITED BY: "_DELBY)
-	D LINE("    DATE/TIME LAST MODIFIED: "_DELTM)
-	D LINE("     SOURCE OF NOTIFICATION: "_$S(SOURCE="":"UNDEFINED",1:SOURCE))
-	;K DEATHVAL,SOURCE,DELTM,DELBY
-	Q
-	;
-LINE(X)	; add line contained in X to array
-	S DGCT=DGCT+1
-	S DGTEXT(DGCT,0)=X
-	Q
-DSBULL	;
-	;
-	I $G(IVMDODUP)=1 Q
-	S DFN=DA
-	I $D(DGPMDA) D  Q
-	.S DISTYPE=$P($G(^DGPM(DGPMDA,0)),"^",18)
-	.I $G(^DG(405.2,DISTYPE,0))["DEATH" D
-	..S FDA(2,DFN_",",.353)=1 D FILE^DIE(,"FDA","BWFERR")
-	..D DISCHRGE,XFR
-	I $D(^TMP("DEATH",$J)) Q
-	D DISCHRGE,XFR
-	Q
-DKBULL	;
-	S DFN=DA
-	S FDA(2,DFN_",",.353)="@"
-	I $D(^TMP("DEATH",$J)) S FDA(2,DFN_",",.355)=DUZ
-	D FILE^DIE(,"FDA",)
-	D DEL
-	Q
-DISCHRGE	;
-	; If the patient is being discharged, determine values needed for 
-	; Source of Notification and Date/Time last entered.
-	;
-	I '$D(DGNOW) S DGNOW=$$HTFM^XLFDT($H)
-	I $G(DGDAUTO)'=1 S FDA(2,DFN_",",.354)=DGNOW
-	S FDA(2,DFN_",",.355)=DUZ
-	D FILE^DIE(,"FDA",)
-	Q
-APTT3	;Check to exclude "While an Inpatient" from DOD Bulletin
-	; Input:  DFN  Output: DGDONOT
-	N DATE,XIEN,TYPE,XDOD,YES
-	S DGDONOT=0
-	S XDOD=$P($G(^DPT(DFN,.35)),"^",1) I 'XDOD Q
-	S XDOD=$P(XDOD,".",1),YES=0,TYPE=""
-	I '$D(^DGPM("APTT3",DFN)) Q
-	S DATE=$O(^DGPM("APTT3",DFN,XDOD)) I 'DATE Q
-	I $P(DATE,".",1)=XDOD S YES=1
-	I ($P(DATE,".",1)-1)=XDOD S YES=1
-	S XIEN=$O(^DGPM("APTT3",DFN,DATE,"")) I 'XIEN Q
-	S TYPE=$P($G(^DGPM(XIEN,0)),"^",4)
-	I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1
-	Q
-SNDISP	; Source of Notification display choices
-	N DIR,DTOUT,DUOUT,DIRUT,DIROUT,DGLIST,DGLNAME,I,X,Y
-	S DGLIST=$P($G(^DD(2,.353,0)),"^",3)
-	S Y=6
-	S DIR("?",1)=" "
-	S DIR("?",2)=" This is a required response. Please select from the following:"
-	S DIR("?",3)=" Entering '^' will take you back to the Source of Notification prompt"
-	S DIR("?",4)=" "
-	S DIR("?",5)=" "
-	F X=1:1 S DGLNAME=$P(DGLIST,";",X) Q:DGLNAME']""  S DIR("?",Y)="      "_$P(DGLNAME,":",1)_"      "_$P(DGLNAME,":",2) S Y=Y+1
-	S DIR("?",Y)=" "
-	F I=1:1 Q:'$D(DIR("?",I))  W !,DIR("?",I)
-	Q
+DGDEATH ;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 10/27/04 9:45pm
+ ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725**;Aug 13, 1993;Build 12
+ ;
+GET N DGMTI,DATA
+ S DGDTHEN="" W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S (DA,DFN)=+Y
+ S DGDOLD=$G(^DPT(DFN,.35))
+ I $D(^DPT(DFN,.1)) W !?3,"Patient is currently in-house.  Discharge him with a discharge type of DEATH." G GET
+ I $S($D(^DPT(DFN,.35)):^(.35),1:"") F DGY=0:0 S DGY=$O(^DGPM("ATID1",DFN,DGY)) Q:'DGY  S DGDA=$O(^(DGY,0)) I $D(^DGPM(+DGDA,0)),$P(^(0),"^",17)]"" S DGXX=$P(^(0),"^",17),DGXX=^DGPM(DGXX,0) I "^12^38^"[("^"_$P(DGXX,"^",18)_"^") G DIS
+ D NOW^%DTC S DGNOW=%
+ S ^TMP("DEATH",$J)=1
+ K A W ! S DIE=DIC,DR=".351" D ^DIE
+ I '$D(^DPT(DFN,.35)) K ^TMP("DEATH",$J) G GET
+ S DGDNEW=^DPT(DFN,.35)
+ I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE
+ I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET
+ I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE
+ I DGDOLD'=DGDNEW D DISCHRGE
+ I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR
+ K ^TMP("DEATH",$J) G GET
+ ;
+DIS W !,"Patient has a discharge type of Death",!,"Edit the discharge",!
+Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN,DGDOLD,DGDNEW,DGDONOT Q
+XFR ; called from set x-ref of field .351 of file 2
+ N DGPCMM,DGFAPT,DGFAPTI,DGFAPT1
+ Q:'$D(DFN)
+ K DGTEXT D ^DGPATV S DGDEATH=$$GET1^DIQ(2,DFN,.351,"I"),XMSUB="PATIENT HAS EXPIRED",DGCT=0
+ D DEMOG
+ S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGPMSTAT
+ S Y=$$FMTE^XLFDT(Y),Y=$S(Y]"":Y,1:"UNKNOWN")
+ S DGDONOT=0 D APTT3
+ D LINE("")
+ D LINE("      Date/Time of Death: "_DEATHVAL_$S(DGDONOT:"",'DG1:"",$D(DGDTHEN):"",1:"  (While an inpatient)"))
+ D LINE("")
+ I '$D(ADM),DG1,$D(^DGPM(+DGA1,0)) S ADM=+^DGPM($P(^(0),"^",14),0)
+ S Y=$$FMTE^XLFDT($S($D(ADM):ADM,1:""))
+ D LINE($S($D(DGDTHEN):"",DG1:"     Admission Date/Time: "_Y_$S((DGDDT-ADM)<1:"  (Within 24 hours of hospitalization)",1:""),1:""))
+ D LINE("")
+ S DGX=$P($G(^DGPM(+$G(DGA1),0)),"^",6),DGX=$P($G(^DIC(42,+DGX,0)),U,1)
+ D LINE($S($D(DGDTHEN):"",('DG1):"",$D(DGA1):"             Admitted To: "_$S(DGX]"":DGX,1:"UNKNOWN"),1:"")) K DGX
+ D LINE("")
+ I DG1&'$D(DGDTHEN) D 
+ . D LINE($S($D(DGXFR0):"           Last Transfer: "_$S($D(^DIC(42,+$P(DGXFR0,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN"),1:""))
+ . D LINE("")
+F N DGARRAY,SDCNT S DGFAPT=DGDEATH,DGFAPTI=""
+ S DGARRAY("FLDS")=3,DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY(1)=DT,DGARRAY(3)="I;R"
+ S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
+ ;
+ I SDCNT>0 F  S DGFAPT=$O(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:'DGFAPT  S DGFAPT1=$G(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:DGFAPT1']""  D  Q:DGFAPTI
+ .I $P($P(DGFAPT1,U,3),";")'["C" D LINE("NOTE: Patient has future appointments scheduled!!") S DGFAPTI=1
+ S DGSCHAD=0 D SA I DGSCHAD D LINE("NOTE: Patient had scheduled admissions which have been cancelled!!")
+ I 'DGVETS D LINE("Patient is a NON-VETERAN."_$S($D(^DIC(21,+$P($G(^DPT(DFN,.32)),"^",3),0)):"  ["_$P(^(0),"^",1)_"]",1:""))
+ S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
+ S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
+Q1 S DGB=1 D ^DGBUL S X=DGDEATH
+ K DGDEATH,DGSCHAD,DGI,Y,DGDDT,^TMP($J,"SDAMA301") D KILL^DGPATV K ADM,DG1,DGA1,DGCT,DGT,DGXX,DGY,Z Q
+SA F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI  I $D(^DGS(41.1,DGI,0)),($P(^(0),"^",13)']""),($P(^(0),"^",17)']"") S $P(^(0),"^",13)=DGDEATH,$P(^(0),"^",14)=+DUZ,$P(^(0),"^",15)=1,$P(^(0),"^",16)=2,DGSCHAD=1
+ Q
+ ;
+DEL ; delete death bulletin
+ N DGPCMM,DELBY,DELTM,DTHINFO
+ S DFN=+$G(DA) I '$D(^DPT(DFN,0)) Q  ; no patient node
+ I +$G(^DPT(DFN,.35)) Q  ; not deletion
+ S DGDEATH=X,XMSUB="Patient Death has been Deleted",DGCT=0
+ D ^DGPATV
+ D LINE("The date of death for the following patient has been deleted.")
+ D LINE("")
+ D DEMOG
+ D LINE("")
+ S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
+ S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
+ S DGB=1 D ^DGBUL S X=DGDEATH
+ K DGCT,DGDEATH D KILL^DGPATV
+ Q
+ ;
+DEMOG ; list main demographics
+ D LINE("                    NAME: "_DGNAME)
+ D LINE("                     SSN: "_$P(SSN,"^",2))
+ D LINE("                     DOB: "_$P(DOB,"^",2))
+ I DGVETS D
+ . N DGX
+ . S DGX=$G(^DPT(DFN,.31))
+ . S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGX,U,4)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
+ . D LINE("   CLAIM FOLDER LOCATION: "_$S($D(DGLOCATN):DGLOCATN,1:"NOT LISTED"))
+ . D LINE("            CLAIM NUMBER: "_$S($P(DGX,"^",3)]"":$P(DGX,"^",3),1:"NOT LISTED"))
+ D LINE("   COORDINATING MASTER OF RECORD: "_DGCMOR)
+ D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","DTHINFO")
+ S DEATHVAL=$G(DTHINFO(2,DFN_",",.351,"E"))
+ S DEATHVAL=$$FMTE^XLFDT(DEATHVAL),DEATHVAL=$S(DEATHVAL]"":DEATHVAL,1:"UNKNOWN")
+ S SOURCE=$G(DTHINFO(2,DFN_",",.353,"E"))
+ S DELTM=$G(DTHINFO(2,DFN_",",.354,"E"))
+ S DELBY=$G(DTHINFO(2,DFN_",",.355,"E"))
+ D LINE("")
+ D LINE("             LAST EDITED BY: "_DELBY)
+ D LINE("    DATE/TIME LAST MODIFIED: "_DELTM)
+ D LINE("     SOURCE OF NOTIFICATION: "_$S(SOURCE="":"UNDEFINED",1:SOURCE))
+ ;K DEATHVAL,SOURCE,DELTM,DELBY
+ Q
+ ;
+LINE(X) ; add line contained in X to array
+ S DGCT=DGCT+1
+ S DGTEXT(DGCT,0)=X
+ Q
+DSBULL ;
+ ;
+ I $G(IVMDODUP)=1 Q
+ S DFN=DA
+ I $D(DGPMDA) D  Q
+ .S DISTYPE=$P($G(^DGPM(DGPMDA,0)),"^",18)
+ .I $G(^DG(405.2,DISTYPE,0))["DEATH" D
+ ..S FDA(2,DFN_",",.353)=1 D FILE^DIE(,"FDA","BWFERR")
+ ..D DISCHRGE,XFR
+ I $D(^TMP("DEATH",$J)) Q
+ D DISCHRGE,XFR
+ Q
+DKBULL ;
+ S DFN=DA
+ S FDA(2,DFN_",",.353)="@"
+ I $D(^TMP("DEATH",$J)) S FDA(2,DFN_",",.355)=DUZ
+ D FILE^DIE(,"FDA",)
+ D DEL
+ Q
+DISCHRGE ;
+ ; If the patient is being discharged, determine values needed for 
+ ; Source of Notification and Date/Time last entered.
+ ;
+ I '$D(DGNOW) S DGNOW=$$HTFM^XLFDT($H)
+ I $G(DGDAUTO)'=1 S FDA(2,DFN_",",.354)=DGNOW
+ S FDA(2,DFN_",",.355)=DUZ
+ D FILE^DIE(,"FDA",)
+ Q
+APTT3 ;Check to exclude "While an Inpatient" from DOD Bulletin
+ ; Input:  DFN  Output: DGDONOT
+ N DATE,XIEN,TYPE,XDOD,YES
+ S DGDONOT=0
+ S XDOD=$P($G(^DPT(DFN,.35)),"^",1) I 'XDOD Q
+ S XDOD=$P(XDOD,".",1),YES=0,TYPE=""
+ I '$D(^DGPM("APTT3",DFN)) Q
+ S DATE=$O(^DGPM("APTT3",DFN,XDOD)) I 'DATE Q
+ I $P(DATE,".",1)=XDOD S YES=1
+ I ($P(DATE,".",1)-1)=XDOD S YES=1
+ S XIEN=$O(^DGPM("APTT3",DFN,DATE,"")) I 'XIEN Q
+ S TYPE=$P($G(^DGPM(XIEN,0)),"^",4)
+ I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENA2.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENA2.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENA2.m	(revision 623)
@@ -1,174 +1,134 @@
-DGENA2	;ALB/CJM,RTK,TDM - Enrollment API - Automatic Update; 9/19/2002 ; 1/31/03 11:54am
-	;;5.3;Registration;**121,122,147,232,327,469,491,779**;Aug 13,1993;Build 11
-	;
-AUTOUPD(DFN,EVENT)	;
-	;Description: If the patient meets the criteria for transmission to HEC,
-	;   he is entered to the IVM PATIENT file for future transmission.
-	;   This procedure checks for changes in enrollment priority,
-	;   status and fields in the eligibility sub-record. If any changes are
-	;   found, the current enrollment record is automatically updated.
-	;Input:
-	;  DFN - Patient IEN
-	;  EVENT - Event Type (optional)
-	;          EVENT 1 : Date of Death Deleted
-	;          EVENT 2 : Ineligible Date Deleted
-	;Output: None
-	;
-	;if the eligibility/enrollment upload is in progess, do not do anything
-	Q:($G(DGENUPLD)="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS")
-	;
-	; If the INCOME TEST DATA (Z10) upload is in progess, do not do anything
-	Q:($G(IVMZ10)="UPLOAD IN PROGRESS")
-	;
-	N DGENRIEN,DGENR1,DGENR2,STATUS,EFFDATE,OK,DEATH
-	;
-	;try to prevent problems rsulting from calling FM within FM
-	N DS,D0,DO,D1,DA,DD,DS,DG,DIC,DICR,DIE,DIG,DIH,DIV,DIW,DIX,DQ,DR
-	;
-	S EVENT=+$G(EVENT)
-	;
-	D EVENT^IVMPLOG(DFN)
-	;
-	D:$$LOCK^DGENA1($G(DFN))  ;may drop out of block
-	.S DGENRIEN=$$FINDCUR^DGENA(DFN)
-	.Q:'DGENRIEN
-	.Q:'$$GET^DGENA(DGENRIEN,.DGENR1)
-	.S STATUS=$$EXT^DGENU("STATUS",DGENR1("STATUS"))
-	.S (DEATH,EFFDATE)=$$DEATH^DGENPTA(DFN)
-	.I STATUS'="VERIFIED",STATUS'="UNVERIFIED",STATUS'="DECEASED",STATUS'["NOT ELIGIBLE",STATUS'["PENDING",STATUS'["REJECTED" Q
-	.I STATUS="DECEASED",((EVENT'=1)!(DEATH)) Q
-	.I STATUS["NOT ELIGIBLE",((EVENT'=2)!('$$VET^DGENPTA(DFN))) Q
-	.S:'EFFDATE EFFDATE=DT
-	.Q:'$$CREATE^DGENA6(DFN,DGENR1("APP"),EFFDATE,DGENR1("REASON"),DGENR1("REMARKS"),.DGENR2,DGENR1("DATE"),DGENR1("END"))
-	.S OK=1
-	.S:(DGENR1("PRIORITY")'=DGENR2("PRIORITY"))!(DGENR2("STATUS")'=DGENR1("STATUS")) OK=0
-	.I OK D
-	..N SUB
-	..S SUB=""
-	..F  S SUB=$O(DGENR2("ELIG",SUB)) Q:SUB=""  S:(DGENR1("ELIG",SUB)'=DGENR2("ELIG",SUB)) OK=0
-	.I 'OK D
-	..I (DGENR1("EFFDATE")=DGENR2("EFFDATE")),(DGENR1("SOURCE")=DGENR2("SOURCE")),(DGENR1("USER")=DGENR2("USER")),(DGENR1("DATETIME")\1)=(DGENR2("DATETIME")\1) D
-	...;in this case it's an overlay
-	...S DGENR2("PRIORREC")=DGENR1("PRIORREC")
-	...I $$EDITCUR^DGENA1(.DGENR2)
-	..E  D
-	...;in this case create a new record, to preserve the audit trail
-	...I $$STORECUR^DGENA1(.DGENR2)
-	D UNLOCK^DGENA1($G(DFN))
-	Q
-MTUPD	;
-	;Description - entry point for Means Test Event Driver for Enrollment
-	;
-	D AUTOUPD($G(DFN))
-	Q
-	;
-SDDIS	;Entry point for the DGEN SD DISPLAY CURRENT ENROLLMENT protocol,
-	;which hangs of the Scheduling Event Driver
-	;
-	N DFN S DFN=$P($G(SDATA),"^",2)
-	;
-	;don't display if running in the background
-	Q:$D(ZTQUEUED)
-	;
-	;don't want to display enrollment for non-vets with no enrollment status
-	Q:('$$VET^DGENPTA(DFN))&('$$STATUS^DGENA(DFN))
-	;
-	;if making an appt., & in interactive mode, display enrollment status
-	I ($G(SDAMEVT)=1),$G(SDMODE)=0 D
-	.D DISPLAY^DGENU($P($G(SDATA),"^",2))
-	.D PAUSE^VALM1
-	;
-	;want to do the same thing for check-in, unless appt just made
-	I ($G(SDAMEVT)=4),$G(SDMODE)=0 D
-	.;want to try avoiding giving display if it was done already
-	.;so, if it is an unscheduled appt made today, skip
-	.N PTNODE,SCNODE
-	.S SCNODE=$G(^TMP("SDAMEVT",$J,"AFTER","SC"))
-	.S PTNODE=$G(^TMP("SDAMEVT",$J,"AFTER","DPT"))
-	.I +$P(SCNODE,"^",7)=$G(DT),$P(PTNODE,"^",7)=4 Q  ;unscheduled appt made today
-	.D DISPLAY^DGENU($P($G(SDATA),"^",2))
-	.D PAUSE^VALM1
-	Q
-	;
-ENROLL	;Entry point for the DGEN SD ENROLL PATIENT protocol, which hangs of
-	;the Scheduling Event Driver. This event enrolls patients upon check-out
-	;if there is no prior enrollment record.
-	;
-	; Input  -- SDATA & SDAMEVT defined by the scheduling event driver
-	; Output -- none
-	;
-	N DGENR,DFN
-	;
-	;NOTE - it appears from testing that means test status REQUIRED is set
-	;within scheduling, obviating the need to do it here.  This is why
-	;several lines are commented out.
-	;
-	;N DGENR,DGOKF,DGREQF,DFN,DGMSGF,DG,DGMT,DGMTCOR,DGMTE,DGRGAUTO,DGWRT,XMZ,DIG,DIH
-	;
-	;appointment made, check if enrollment appointment request needs reset.
-	I $G(SDAMEVT)=1 D REQUST(SDAMEVT,SDATA)
-	;check-out?
-	Q:($G(SDAMEVT)'=5)
-	;
-	S DFN=$P($G(SDATA),"^",2)
-	;
-	;don't enroll if the patient has an enrollment record
-	I $$FINDCUR^DGENA(DFN) D REQUST(SDAMEVT,SDATA) Q
-	;
-	;non-vet?
-	Q:'$$VET^DGENPTA(DFN)
-	;
-	;dead?
-	Q:$$DEATH^DGENPTA(DFN)
-	;
-	;Does patient require a Means Test?
-	;S DGMSGF=1
-	;D EN^DGMTR
-	;
-	;Create local enrollment array
-	I $$CREATE^DGENA6(DFN,DT,,,,.DGENR) D
-	. ;
-	. ;Store local enrollment as current
-	. I $$STORECUR^DGENA1(.DGENR) D
-	. . D REQUST(SDAMEVT,SDATA)
-	. . ;
-	. . ;If patient's means test status is required, send bulletin
-	. . ;I $$MTREQ^DGEN(DFN) D MTBULL^DGEN(DFN,.DGENR)
-	Q
-	;
-REQUST(SDAMEVT,SDATA)	;
-	;Automatic collection of Appointment Request Date and Appointment
-	;Request Response
-	;- Set when Enrollment Application Date >= 8/1/2005 AND
-	;-     Appointment Request Date is null. 
-	;
-	; Input  -- SDATA and SDAMEVT defined by scheduling event driver
-	; Output -- none
-	;
-	N DGENRIEN,DGENR,DPTERR,DGCOM
-	;apointment made or checked out?
-	Q:(($G(SDAMEVT)'=1)&($G(SDAMEVT)'=5))
-	;
-	S DFN=$P($G(SDATA),"^",2)
-	;get enrollment ien
-	S DGENRIEN=$$FINDCUR^DGENA(DFN)
-	I DGENRIEN,$$GET^DGENA(DGENRIEN,.DGENR) ;set-up enrollment array
-	I $G(DGENR("APP"))>3050731 D
-	. ;and, no appointment request date. Set request="yes", request date 
-	. I '$$GET1^DIQ(2,DFN,1010.1511,"I") D
-	. . ;set fields
-	. . N FDATA
-	. . S FDATA(2,DFN_",",1010.159)=1
-	. . S FDATA(2,DFN_",",1010.1511)=DT
-	. . D FILE^DIE("","FDATA","DPTERR")
-	. ;if appointment made (or checkout), appt. request="yes", request status'="filled"
-	. ;- set request status='filled' w comment
-	. I ($$GET1^DIQ(2,DFN,1010.159,"I")),($$GET1^DIQ(2,DFN,1010.161,"I")'="F") D
-	. . ;set fields
-	. . N FDATA
-	. . S FDATA(2,DFN_",",1010.161)="F"
-	. . S DGCOM=$$GET1^DIQ(2,DFN,1010.163)
-	. . S DGCOM=DGCOM_$S(DGCOM'="":"<>",1:"")_"AutoComm:"_$S($$GET1^DIQ(2,DFN,1010.161,"I")="":"null",1:$S($$GET1^DIQ(2,DFN,1010.161,"I")="I":"IN PROGRESS",1:$$GET1^DIQ(2,DFN,1010.161)))_"|FILLED by Scheduling"
-	. . S FDATA(2,DFN_",",1010.163)=DGCOM
-	. . D FILE^DIE("","FDATA","DPTERR")
-	Q
+DGENA2 ;ALB/CJM,RTK,TDM - Enrollment API - Automatic Update; 9/19/2002 ; 1/31/03 11:54am
+ ;;5.3;Registration;**121,122,147,232,327,469,491**;Aug 13,1993
+ ;
+AUTOUPD(DFN,EVENT) ;
+ ;Description: If the patient meets the criteria for transmission to HEC,
+ ;   he is entered to the IVM PATIENT file for future transmission.
+ ;   This procedure checks for changes in enrollment priority,
+ ;   status and fields in the eligibility sub-record. If any changes are
+ ;   found, the current enrollment record is automatically updated.
+ ;Input:
+ ;  DFN - Patient IEN
+ ;  EVENT - Event Type (optional)
+ ;          EVENT 1 : Date of Death Deleted
+ ;          EVENT 2 : Ineligible Date Deleted
+ ;Output: None
+ ;
+ ;if the eligibility/enrollment upload is in progess, do not do anything
+ Q:($G(DGENUPLD)="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS")
+ ;
+ ; If the INCOME TEST DATA (Z10) upload is in progess, do not do anything
+ Q:($G(IVMZ10)="UPLOAD IN PROGRESS")
+ ;
+ N DGENRIEN,DGENR1,DGENR2,STATUS,EFFDATE,OK,DEATH
+ ;
+ ;try to prevent problems rsulting from calling FM within FM
+ N DS,D0,DO,D1,DA,DD,DS,DG,DIC,DICR,DIE,DIG,DIH,DIV,DIW,DIX,DQ,DR
+ ;
+ S EVENT=+$G(EVENT)
+ ;
+ D EVENT^IVMPLOG(DFN)
+ ;
+ D:$$LOCK^DGENA1($G(DFN))  ;may drop out of block
+ .S DGENRIEN=$$FINDCUR^DGENA(DFN)
+ .Q:'DGENRIEN
+ .Q:'$$GET^DGENA(DGENRIEN,.DGENR1)
+ .S STATUS=$$EXT^DGENU("STATUS",DGENR1("STATUS"))
+ .S (DEATH,EFFDATE)=$$DEATH^DGENPTA(DFN)
+ .I STATUS'="VERIFIED",STATUS'="UNVERIFIED",STATUS'="DECEASED",STATUS'["NOT ELIGIBLE",STATUS'["PENDING",STATUS'["REJECTED" Q
+ .I STATUS="DECEASED",((EVENT'=1)!(DEATH)) Q
+ .I STATUS["NOT ELIGIBLE",((EVENT'=2)!('$$VET^DGENPTA(DFN))) Q
+ .S:'EFFDATE EFFDATE=DT
+ .Q:'$$CREATE^DGENA6(DFN,DGENR1("APP"),EFFDATE,DGENR1("REASON"),DGENR1("REMARKS"),.DGENR2,DGENR1("DATE"),DGENR1("END"))
+ .S OK=1
+ .S:(DGENR1("PRIORITY")'=DGENR2("PRIORITY"))!(DGENR2("STATUS")'=DGENR1("STATUS")) OK=0
+ .I OK D
+ ..N SUB
+ ..S SUB=""
+ ..F  S SUB=$O(DGENR2("ELIG",SUB)) Q:SUB=""  S:(DGENR1("ELIG",SUB)'=DGENR2("ELIG",SUB)) OK=0
+ .I 'OK D
+ ..I (DGENR1("EFFDATE")=DGENR2("EFFDATE")),(DGENR1("SOURCE")=DGENR2("SOURCE")),(DGENR1("USER")=DGENR2("USER")),(DGENR1("DATETIME")\1)=(DGENR2("DATETIME")\1) D
+ ...;in this case it's an overlay
+ ...S DGENR2("PRIORREC")=DGENR1("PRIORREC")
+ ...I $$EDITCUR^DGENA1(.DGENR2)
+ ..E  D
+ ...;in this case create a new record, to preserve the audit trail
+ ...I $$STORECUR^DGENA1(.DGENR2)
+ D UNLOCK^DGENA1($G(DFN))
+ Q
+MTUPD ;
+ ;Description - entry point for Means Test Event Driver for Enrollment
+ ;
+ D AUTOUPD($G(DFN))
+ Q
+ ;
+SDDIS ;Entry point for the DGEN SD DISPLAY CURRENT ENROLLMENT protocol,
+ ;which hangs of the Scheduling Event Driver
+ ;
+ N DFN S DFN=$P($G(SDATA),"^",2)
+ ;
+ ;don't display if running in the background
+ Q:$D(ZTQUEUED)
+ ;
+ ;don't want to display enrollment for non-vets with no enrollment status
+ Q:('$$VET^DGENPTA(DFN))&('$$STATUS^DGENA(DFN))
+ ;
+ ;if making an appt., & in interactive mode, display enrollment status
+ I ($G(SDAMEVT)=1),$G(SDMODE)=0 D
+ .D DISPLAY^DGENU($P($G(SDATA),"^",2))
+ .D PAUSE^VALM1
+ ;
+ ;want to do the same thing for check-in, unless appt just made
+ I ($G(SDAMEVT)=4),$G(SDMODE)=0 D
+ .;want to try avoiding giving display if it was done already
+ .;so, if it is an unscheduled appt made today, skip
+ .N PTNODE,SCNODE
+ .S SCNODE=$G(^TMP("SDAMEVT",$J,"AFTER","SC"))
+ .S PTNODE=$G(^TMP("SDAMEVT",$J,"AFTER","DPT"))
+ .I +$P(SCNODE,"^",7)=$G(DT),$P(PTNODE,"^",7)=4 Q  ;unscheduled appt made today
+ .D DISPLAY^DGENU($P($G(SDATA),"^",2))
+ .D PAUSE^VALM1
+ Q
+ ;
+ENROLL ;Entry point for the DGEN SD ENROLL PATIENT protocol, which hangs of
+ ;the Scheduling Event Driver. This event enrolls patients upon check-out
+ ;if there is no prior enrollment record.
+ ;
+ ; Input  -- SDATA & SDAMEVT defined by the scheduling event driver
+ ; Output -- none
+ ;
+ N DGENR,DFN
+ ;
+ ;NOTE - it appears from testing that means test status REQUIRED is set
+ ;within scheduling, obviating the need to do it here.  This is why
+ ;several lines are commented out.
+ ;
+ ;N DGENR,DGOKF,DGREQF,DFN,DGMSGF,DG,DGMT,DGMTCOR,DGMTE,DGRGAUTO,DGWRT,XMZ,DIG,DIH
+ ;
+ ;check-out?
+ Q:($G(SDAMEVT)'=5)
+ ;
+ S DFN=$P($G(SDATA),"^",2)
+ ;
+ ;don't enroll if the patient has an enrollment record
+ Q:$$FINDCUR^DGENA(DFN)
+ ;
+ ;non-vet?
+ Q:'$$VET^DGENPTA(DFN)
+ ;
+ ;dead?
+ Q:$$DEATH^DGENPTA(DFN)
+ ;
+ ;Does patient require a Means Test?
+ ;S DGMSGF=1
+ ;D EN^DGMTR
+ ;
+ ;Create local enrollment array
+ I $$CREATE^DGENA6(DFN,DT,,,,.DGENR) D
+ . ;
+ . ;Store local enrollment as current
+ . I $$STORECUR^DGENA1(.DGENR) D
+ . . ;
+ . . ;If patient's means test status is required, send bulletin
+ . . ;I $$MTREQ^DGEN(DFN) D MTBULL^DGEN(DFN,.DGENR)
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENUPLB.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENUPLB.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENUPLB.m	(revision 623)
@@ -1,45 +1,82 @@
-DGENUPLB	;ALB/TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 11/14/07 3:02pm
-	;;5.3;REGISTRATION;**625,763**;Aug 13,1993;Build 9
-	;
-EP	N MSGARY
-	D CHECK
-	Q
-	;
-CHECK	;Check for Rated Disability Changes
-	Q:'$D(DGELG)
-	N RDOCC,TMPARY,RD,RDOCC1,RDOCC2,RDFLG,RDNOD
-	;
-	;Change in Rated Disabilities
-	I $D(OLDELG("RATEDIS")) D
-	.S RDOCC=0 F  S RDOCC=$O(OLDELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
-	..S RD=$P(OLDELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
-	..S TMPARY(RD)=RDOCC
-	;
-	I $D(DGELG("RATEDIS")) D
-	.S RDOCC=0 F  S RDOCC=$O(DGELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
-	..S RD=$P(DGELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
-	..S $P(TMPARY(RD),"^",2)=RDOCC
-	;
-	I $D(TMPARY) D
-	.S RD=""
-	.F  S RD=$O(TMPARY(RD)) Q:RD=""  D
-	..S RDOCC2=+$P(TMPARY(RD),"^",2) Q:'RDOCC2
-	..S RDOCC1=+$P(TMPARY(RD),"^")
-	..I 'RDOCC1 D STOR390 Q
-	..S RDFLG=0
-	..F RDNOD="RD","PER","RDSC","RDEXT","RDORIG","RDCURR" D  Q:RDFLG
-	...I $G(OLDELG("RATEDIS",RDOCC1,RDNOD))'=$G(DGELG("RATEDIS",RDOCC2,RDNOD)) D STOR390
-	Q
-	;
-STOR390	;Store Data in file# 390
-	S RDFLG=1
-	N DATA,DA
-	S DATA(.01)=$$NOW^XLFDT
-	S DATA(2)=DFN
-	S DATA(3)=DGELG("RATEDIS",RDOCC2,"RD")
-	S DATA(4)=DGELG("RATEDIS",RDOCC2,"PER")
-	S DATA(5)=DGELG("RATEDIS",RDOCC2,"RDEXT")
-	S DATA(6)=DGELG("RATEDIS",RDOCC2,"RDORIG")
-	S DATA(7)=DGELG("RATEDIS",RDOCC2,"RDCURR")
-	I '$$ADD^DGENDBS(390,,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILITY UPLOAD AUDIT"
-	Q
+DGENUPLB ;TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 10/26/04 2:01pm
+ ;;5.3;REGISTRATION;**625**;Aug 13,1993
+ ;
+EP N MSGARY
+ D CHECK,SNDMSG
+ Q
+ ;
+CHECK ;Perform C&P and SC status checks and generate mailman messages
+ ;for MCCR eligibility & billing staff.
+ Q:'$D(OLDELG)
+ N RDOCC,TMPARY,RD,RDOCC1,RDOCC2,RDFLG
+ ;
+ ;Change in SC Indicator
+ I OLDELG("SC")'=DGELG("SC") D
+ .Q:(OLDELG("SC")="")&(DGELG("SC")="N")
+ .Q:(OLDELG("SC")="N")&(DGELG("SC")="")
+ .D ADDMSG^DGENUPL3(.MSGARY,"VETERAN SC INDICATOR CHANGED",1)
+ ;
+ ;SC% change to 50% or greater
+ I (OLDELG("SCPER")<50),(DGELG("SCPER")>49) D ADDMSG^DGENUPL3(.MSGARY,"VETERAN SC% CHANGED TO 50% OR GREATER",1)
+ ;
+ ;Change in VA Pension
+ I OLDELG("VAPEN")'=DGELG("VAPEN") D
+ .Q:(OLDELG("VAPEN")="")&(DGELG("VAPEN")="N")
+ .Q:(OLDELG("VAPEN")="N")&(DGELG("VAPEN")="")
+ .D ADDMSG^DGENUPL3(.MSGARY,"VETERAN VA PENSION CHANGED",1)
+ ;
+ ;Change in Rated Disabilities
+ I $D(OLDELG("RATEDIS")) D
+ .S RDOCC=0 F  S RDOCC=$O(OLDELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
+ ..S RD=$P(OLDELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
+ ..S TMPARY(RD)=RDOCC
+ ;
+ I $D(DGELG("RATEDIS")) D
+ .S RDOCC=0 F  S RDOCC=$O(DGELG("RATEDIS",RDOCC)) Q:RDOCC=""  D
+ ..S RD=$P(DGELG("RATEDIS",RDOCC,"RD"),"^") Q:RD=""
+ ..S $P(TMPARY(RD),"^",2)=RDOCC
+ ;
+ I $D(TMPARY) D
+ .S RD="",RDFLG=0
+ .F  S RD=$O(TMPARY(RD)) Q:RD=""  D
+ ..S RDOCC1=+$P(TMPARY(RD),"^"),RDOCC2=+$P(TMPARY(RD),"^",2)
+ ..I $G(OLDELG("RATEDIS",RDOCC1,"RD"))'=$G(DGELG("RATEDIS",RDOCC2,"RD")) S RDFLG=1
+ .I RDFLG D ADDMSG^DGENUPL3(.MSGARY,"VETERAN RATED DISABILITIES CHANGED",1)
+ Q
+ ;
+SNDMSG ;Description: Send messages generated above to the G.IB MEANS TEST
+ ;mail group.
+ ;
+ N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT
+ N HEADER,NSC,POW,TMPSTR,XMGROUP,ELIG,CD
+ ;
+ ;if there are no alerts, then quit
+ Q:'$D(MSGARY)
+ S HEADER="C&P Alert: ",XMDF="",(XMDUN,XMDUZ)="Registration Enrollment Module"
+ ;DGPAT("SSN") is built by the parser. DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT.
+ ;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge.
+ I '$D(DGPAT("NAME")) S DGPAT("NAME")=$G(OLDPAT("NAME"))
+ I '$D(DGPAT("SEX")) S DGPAT("SEX")=$G(OLDPAT("SEX"))
+ I '$D(DGPAT("DOB")) S DGPAT("DOB")=$G(OLDPAT("DOB"))
+ S TMPSTR=" ("_$E(DGPAT("NAME"),1,1)
+ S TMPSTR=TMPSTR_$E(DGPAT("SSN"),$L(DGPAT("SSN"))-3,1000)_")"
+ S XMSUB=HEADER_$E(DGPAT("NAME"),1,25)_TMPSTR
+ ;
+ ; send msg to mail group in IB SITE PARAMETERS (#350.9) file
+ S XMY("G.IB MEANS TEST")=""    ; Means Test billing Group
+ ;
+ S XMTEXT="TEXT("
+ S TEXT(1)="The enrollment/eligibility upload produced the following alerts:"
+ S TEXT(2)="  "
+ S TEXT(3)="Patient Name   :     "_DGPAT("NAME")
+ S TEXT(4)="SSN            :     "_DGPAT("SSN")
+ S TEXT(5)="DOB            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB"))
+ S TEXT(6)="SEX            :     "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX"))
+ S TEXT(7)=" "
+ ;
+ S TEXT(8)=" ** Alerts **"
+ S TEXT(9)=" "
+ S COUNT=0 F  S COUNT=$O(MSGARY(COUNT)) Q:'COUNT  S TEXT(10+COUNT)=COUNT_") "_MSGARY(COUNT)
+ ;
+ D ^XMD
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGLBPID.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGLBPID.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGLBPID.m	(revision 623)
@@ -1,116 +1,116 @@
-DGLBPID	;DJW,TOAD; Health Record Number Identifier ;5/1/07  20:26
-	;;5.3;Registration;**634**;Aug 13, 1993;Build 30
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-	;'Modified' MAS Patient Look-up Check Cross-References June 1987
-	Q
-	;
-	;
-ID(DFN)	;GFT/VW  IA 10035
-	N ID S ID=$P($G(^DPT(DFN,.36)),U,3) ;PRIMARY LONG ID
-	I ID="" S ID=$$HRN(DFN)
-	I ID="" S ID=$P($G(^DPT(DFN,0)),U,9) I ID]"" S ID=$E(ID,1,3)_"-"_$E(ID,4,5)_"-"_$E(ID,6,99)
-	I ID="" D
-	.N I F I=0:0 S I=$O(^AUPNPAT(DFN,41,I)) Q:'I  I $P($G(^(I,0)),U,5)="" S ID=$P($G(^(0)),U,2) I ID]"" S ID=ID_" ("_$P($G(^DIC(4,I,0)),U,5)_")" Q
-	I ID="" S ID="`"_DFN
-	Q ID
-	;
-	;
-	;
-	;
-HRN(DFN)	;LOOKUP HEALTH RECORD NUMBER
-	I '$G(DUZ(2)) Q ""
-	Q $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
-	;
-	;
-GOTIDQ(DFN)	;Do we have the needed number for this guy?
-	N T S T=$$REQID(DFN)
-	I T="SSN" Q $P(^DPT(DFN,0),U,9)]""
-	I T="HRN" Q:'$G(DUZ(2)) 0 Q $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)]""
-	Q 1
-	;
-	;
-REQID(DFN)	;WHICH IDENTIFICATION FORMAT IS REQUIRED?
-	N TYPE S TYPE=""
-	D:$G(DFN)
-	.S TYPE=+$G(^DPT(DFN,.361)) I TYPE S TYPE=$P($G(^DIC(8,TYPE,0)),U,9) ;try PRIMARY ELIGIBILITY CODE
-	.I TYPE="" S TYPE=+$G(^DPT(DFN,"TYPE")) I TYPE S TYPE=+$G(^DG(391,TYPE,8.2)) ;try patient TYPE
-	I 'TYPE S TYPE=$G(DUZ("AG")),TYPE=$S(TYPE="V":1,1:2) ;or just assume it's HRN if not VA
-	Q $P("SSN^HRN",U,TYPE)
-	;
-	;
-IDCAP()	;Returns 3 characters: " ID" or "SSN"
-	I $G(DUZ("AG"))="E" Q " ID"
-	Q "SSN"
-	;
-	;
-	;
-	;
-	;
-	;
-LONGID	;Called by ^DIC(8.2,2,"LONG") (assumes DA(1) is DFN!)
-	N INSTITU,DFN,DFNID,SSNID,IHSID D GETALL
-	S X=$S($G(IHSID("L"))'?."-":IHSID("L"),$G(SSNID("L"))'?."-":SSNID("L"),$G(DFNID("L"))'?."-":DFNID("L"),1:"")
-	;I X="" W 1/0  ;some LONGID must exist for a patient, else ERROR!
-	Q
-	;
-	;
-SHORTID	;Called by ^DIC(8.2,2,"SHORT") (assumes DA(1) is DFN!)
-	N INSTITU,DFN,DFNID,SSNID,IHSID D GETALL
-	S X=$S($G(IHSID("S"))'?."-":IHSID("S"),$G(SSNID("S"))'?."-":SSNID("S"),$G(DFNID("S"))'?."-":DFNID("S"),1:"")
-	;I X="" W 1/0  ;some SHORTID must exist for a patient, else ERROR!
-	Q
-	;
-	;
-IHSID	;
-	;given INSTITU (current institution #)
-	;get HEALTH RECORD NUMBER (Multiple 4101, 9000001.41) associated
-	;with the institution
-	S IHSID=$P($G(^AUPNPAT(DFN,41,+INSTITU,0)),"^",2)
-	I IHSID'="" D
-	. S IHSID("L")=IHSID ; $J(IHSID,12) ; if we want to zero pad then $TR($J(IHSID("L"),12)," ",0)
-	. S IHSID("S")=$TR(IHSID("L"),$TR(IHSID("L"),9876543210))
-	. S IHSID("S")=$TR($J(IHSID("S"),4)," ",0)
-	. S IHSID("S")=$E(IHSID("S"),$L(IHSID("S"))-3,$L(IHSID("S")))
-	;now return Health Record Number
-	Q
-DFNID	S DFN=DA(1) ; IEN in patient file, with default institution from
-	;kernel system parameters file as prefix.
-	;8989.3,217    DEFAULT INSTITUTION of #8989.3 -- KERNEL SYSTEM PARAMETERS FILE
-	S INSTITU=$P($G(^XTV(8989.3,1,"XUS")),U,17)
-	;150.9  VISIT TRACKING PARAMETERS :: DEFAULT INSTITUTION:
-	I INSTITU="",$P($G(^DIC(150.9,1,0)),U,4)'="" S INSTITU=$P(^(0),U,4)
-	; if we have a medical record number in IHS PATIENT, for this
-	I INSTITU'="",$P($G(^DIC(4,+INSTITU,99)),U)'="" S INSTITU("STA#")=$P(^(99),U)
-	; now put INSTITUtion STATION NUMBER as prefix to DFN as "DFNID"
-	S DFNID("S")="`"_DFN,DFNID("L")=999_"-`"_DFN S:$D(INSTITU("STA#"))#2 DFNID("L")=INSTITU("STA#")_"-`"_DFN
-	Q
-SSNID	;
-	;code scarfed from ^DIC(8.2,1,"LONG") - retrieving the SSN
-	N X
-	S SSNID("L")="" I $D(DFN),$D(^DPT(DFN,0)) S X=$P(^(0),U,9),SSNID("L")=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10)
-	S SSNID("S")=$P(SSNID("L"),"-",3)
-	Q
-GETALL	;
-	;Utility Subroutine to Getall the variables
-	D DFNID,IHSID,SSNID
-	;K DFNID,SSNID ; kill because HRN is "required"
-	Q
-	;
-ENALL	;RE-INDEX PHONE NUMBER (KIDS POST-INSTALL DG*5.3*634)
-	K ^DPT("AZVWVOE")
-	N DIK S DIK="^DPT(",DIK(1)=".131^251000" D ENALL^DIK
-	Q
+DGLBPID ;DJW,TOAD; Health Record Number Identifier ;5/1/07  20:26
+ ;;5.3;Registration;**634**;Aug 13, 1993;Build 28
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;'Modified' MAS Patient Look-up Check Cross-References June 1987
+ Q
+ ;
+ ;
+ID(DFN) ;GFT/VW  IA 10035
+ N ID S ID=$P($G(^DPT(DFN,.36)),U,3) ;PRIMARY LONG ID
+ I ID="" S ID=$$HRN(DFN)
+ I ID="" S ID=$P($G(^DPT(DFN,0)),U,9) I ID]"" S ID=$E(ID,1,3)_"-"_$E(ID,4,5)_"-"_$E(ID,6,99)
+ I ID="" D
+ .N I F I=0:0 S I=$O(^AUPNPAT(DFN,41,I)) Q:'I  I $P($G(^(I,0)),U,5)="" S ID=$P($G(^(0)),U,2) I ID]"" S ID=ID_" ("_$P($G(^DIC(4,I,0)),U,5)_")" Q
+ I ID="" S ID="`"_DFN
+ Q ID
+ ;
+ ;
+ ;
+ ;
+HRN(DFN) ;LOOKUP HEALTH RECORD NUMBER
+ I '$G(DUZ(2)) Q ""
+ Q $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+ ;
+ ;
+GOTIDQ(DFN) ;Do we have the needed number for this guy?
+ N T S T=$$REQID(DFN)
+ I T="SSN" Q $P(^DPT(DFN,0),U,9)]""
+ I T="HRN" Q:'$G(DUZ(2)) 0 Q $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)]""
+ Q 1
+ ;
+ ;
+REQID(DFN) ;WHICH IDENTIFICATION FORMAT IS REQUIRED?
+ N TYPE S TYPE=""
+ D:$G(DFN)
+ .S TYPE=+$G(^DPT(DFN,.361)) I TYPE S TYPE=$P($G(^DIC(8,TYPE,0)),U,9) ;try PRIMARY ELIGIBILITY CODE
+ .I TYPE="" S TYPE=+$G(^DPT(DFN,"TYPE")) I TYPE S TYPE=+$G(^DG(391,TYPE,8.2)) ;try patient TYPE
+ I 'TYPE S TYPE=$G(DUZ("AG")),TYPE=$S(TYPE="V":1,1:2) ;or just assume it's HRN if not VA
+ Q $P("SSN^HRN",U,TYPE)
+ ;
+ ;
+IDCAP() ;Returns 3 characters: " ID" or "SSN"
+ I $G(DUZ("AG"))="E" Q " ID"
+ Q "SSN"
+ ;
+ ;
+ ;
+ ;
+ ;
+ ;
+LONGID ;Called by ^DIC(8.2,2,"LONG") (assumes DA(1) is DFN!)
+ N INSTITU,DFN,DFNID,SSNID,IHSID D GETALL
+ S X=$S($G(IHSID("L"))'?."-":IHSID("L"),$G(SSNID("L"))'?."-":SSNID("L"),$G(DFNID("L"))'?."-":DFNID("L"),1:"")
+ ;I X="" W 1/0  ;some LONGID must exist for a patient, else ERROR!
+ Q
+ ;
+ ;
+SHORTID ;Called by ^DIC(8.2,2,"SHORT") (assumes DA(1) is DFN!)
+ N INSTITU,DFN,DFNID,SSNID,IHSID D GETALL
+ S X=$S($G(IHSID("S"))'?."-":IHSID("S"),$G(SSNID("S"))'?."-":SSNID("S"),$G(DFNID("S"))'?."-":DFNID("S"),1:"")
+ ;I X="" W 1/0  ;some SHORTID must exist for a patient, else ERROR!
+ Q
+ ;
+ ;
+IHSID ;
+ ;given INSTITU (current institution #)
+ ;get HEALTH RECORD NUMBER (Multiple 4101, 9000001.41) associated
+ ;with the institution
+ S IHSID=$P($G(^AUPNPAT(DFN,41,+INSTITU,0)),"^",2)
+ I IHSID'="" D
+ . S IHSID("L")=IHSID ; $J(IHSID,12) ; if we want to zero pad then $TR($J(IHSID("L"),12)," ",0)
+ . S IHSID("S")=$TR(IHSID("L"),$TR(IHSID("L"),9876543210))
+ . S IHSID("S")=$TR($J(IHSID("S"),4)," ",0)
+ . S IHSID("S")=$E(IHSID("S"),$L(IHSID("S"))-3,$L(IHSID("S")))
+ ;now return Health Record Number
+ Q
+DFNID S DFN=DA(1) ; IEN in patient file, with default institution from
+ ;kernel system parameters file as prefix.
+ ;8989.3,217    DEFAULT INSTITUTION of #8989.3 -- KERNEL SYSTEM PARAMETERS FILE
+ S INSTITU=$P($G(^XTV(8989.3,1,"XUS")),U,17)
+ ;150.9  VISIT TRACKING PARAMETERS :: DEFAULT INSTITUTION:
+ I INSTITU="",$P($G(^DIC(150.9,1,0)),U,4)'="" S INSTITU=$P(^(0),U,4)
+ ; if we have a medical record number in IHS PATIENT, for this
+ I INSTITU'="",$P($G(^DIC(4,+INSTITU,99)),U)'="" S INSTITU("STA#")=$P(^(99),U)
+ ; now put INSTITUtion STATION NUMBER as prefix to DFN as "DFNID"
+ S DFNID("S")="`"_DFN,DFNID("L")=999_"-`"_DFN S:$D(INSTITU("STA#"))#2 DFNID("L")=INSTITU("STA#")_"-`"_DFN
+ Q
+SSNID ;
+ ;code scarfed from ^DIC(8.2,1,"LONG") - retrieving the SSN
+ N X
+ S SSNID("L")="" I $D(DFN),$D(^DPT(DFN,0)) S X=$P(^(0),U,9),SSNID("L")=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10)
+ S SSNID("S")=$P(SSNID("L"),"-",3)
+ Q
+GETALL ;
+ ;Utility Subroutine to Getall the variables
+ D DFNID,IHSID,SSNID
+ ;K DFNID,SSNID ; kill because HRN is "required"
+ Q
+ ;
+ENALL ;RE-INDEX PHONE NUMBER (KIDS POST-INSTALL DG*5.3*634)
+ K ^DPT("AZVWVOE")
+ N DIK S DIK="^DPT(",DIK(1)=".131^251000" D ENALL^DIK
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMSTAPI.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMSTAPI.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMSTAPI.m	(revision 623)
@@ -1,307 +1,307 @@
-DGMSTAPI	;ALB/SCK - API's for Military Sexual Trauma ;7:34 PM  30 Jan 2008
-	;;5.3;Registration;**195,243,308,353,379,443,700,VWEHR1**;WorldVistA 30-Jan-08;Build 4
-	;
-	;Modified from FOIA VISTA,
-	;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
-	;General Public License See attached copy of the License.
-	;
-	;This program is free software; you can redistribute it and/or modify
-	;it under the terms of the GNU General Public License as published by
-	;the Free Software Foundation; either version 2 of the License, or
-	;(at your option) any later version.
-	;
-	;This program is distributed in the hope that it will be useful,
-	;but WITHOUT ANY WARRANTY; without even the implied warranty of
-	;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	;GNU General Public License for more details.
-	;
-	;You should have received a copy of the GNU General Public License along
-	;with this program; if not, write to the Free Software Foundation, Inc.,
-	;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-	;
-	Q
-	;
-GETSTAT(DFN,DGDATE)	;  Retrieves the current MST status for a patient
-	;
-	;  Input
-	;    DFN  - IEN of patient in the PATIENT File (#2)
-	;    DGDATE - Date for status lookup [OPTIONAL]
-	;
-	;  Output
-	;    DGMST - Format will depend on result of lookup
-	;
-	;    If an entry is found then:
-	;       DGMST returns a 7 piece data string, caret(^)-delimited:
-	;        $P(1) = IEN of entry in MST HISTORY File (#29.11)
-	;        $P(2) = Internal value of MST Status ("Y,N,D,U")
-	;        $P(3) = Date of status change
-	;        $P(4) = IEN of provider making determination, file (#200)
-	;        $P(5) = IEN of user who entered status, file (#200)
-	;        $P(6) = External format of MST Status
-	;        $P(7) = IEN pointer of the INSTITUTION file (#4)
-	;
-	;    If no MST History is found, then:
-	;       DGMST = 0^U
-	;                "U" = (Unknown)
-	;    If an error occured in the GETS^DIQ lookup, then:
-	;       DGMST = -1^^Error Code IEN
-	;                   (returned by GETS^DIQ call)
-	;
-	; Get most recent MST status entry for the patient from file using
-	;  reverse $Order on the "APDT" x-ref.
-	;
-	N DGMST,DGIEN,DGFDA,DGMSG
-	S DFN=$G(DFN)
-	I '+DFN!('$D(^DPT(DFN,0))) D  G STATQ
-	. S DGMST="-1"
-	I '$D(^DGMS(29.11,"APDT",DFN))  D  G STATQ
-	.S DGMST="0^U"
-	S DGDATE=$S(+$G(DGDATE)>0:DGDATE,1:$$NOW^XLFDT)
-	I '$D(^DGMS(29.11,"APDT",DFN,DGDATE)) S DGDATE=$$DATE(DFN,DGDATE)
-	I '+DGDATE D  G STATQ
-	. S DGMST="0^U"
-	S DGIEN=""
-	;
-	;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
-	;
-	;S DGIEN=+$P($Q(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1),",",5)
-	S DGIEN=+$P($$Q^VWUTIL($NA(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN)),-1),",",5)
-	;
-	;END CHANGE
-	;
-	; Check for valid ien, if entry missing, return Unknown
-	I +DGIEN'>0 D  G STATQ
-	. S DGMST="0^U"
-	;
-	; Retrieve data
-	D GETS^DIQ(29.11,+DGIEN_",","*","IE","DGFDA","DGMSG")
-	; check for errors
-	I $D(DGMSG) D  G STATQ
-	.S DGMST="-1^^"_$G(DGMSG("DIERR",1))
-	;
-	S DGMST=DGIEN_U_$G(DGFDA(29.11,+DGIEN_",",3,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",.01,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",4,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",5,"I"))
-	S DGMST=DGMST_U_$G(DGFDA(29.11,+DGIEN_",",3,"E"))
-	S DGMST=DGMST_U_$S($G(DGFDA(29.11,+DGIEN_",",6,"I"))]"":$G(DGFDA(29.11,+DGIEN_",",6,"I")),1:$$SITE)
-	;
-STATQ	Q $G(DGMST)
-	;
-NEWSTAT(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGXMIT)	; MST HISTORY (#29.11) filer
-	; Callpoint to create a new MST HISTORY FILE (#29.11) entry.
-	; Will also queue HL7 message for HEC database updates.
-	;
-	;  Input
-	;    DFN    - Patients DFN
-	;    DGSTAT - MST Status code, "Y,N,D,U"
-	;    DGDATE - Date of MST status change  [default=NOW]
-	;    DGPROV - IEN of Provider making determination, file (#200)
-	;    DGSITE - IEN pointer of the INSTITUTION file (#4)
-	;    DGXMIT - HL7 transmit flag [OPTIONAL]
-	;              0=don't queue a message
-	;              1=queue a message [default])
-	;
-	;  Output
-	;    DGRSLT - Returns IEN of file (#29.11) entry if successful
-	;
-	;    If no patient was defined, then:
-	;       DGRSLT = -1^No patient defined
-	;
-	;    If an error occured in the GETS^DIQ lookup, then:
-	;       DGMST = -1^^Error Code IEN
-	;                   (returned by GETS^DIQ call)
-	;
-	N DGFDA,DGMSG,DGERR,DGRSLT,MSTIEN
-	S DFN=$G(DFN)
-	I DFN']""!('$D(^DPT(DFN,0))) D  G NEWQ
-	. S DGRSLT="-1^No patient defined"
-	;
-	S DGSTAT=$S($G(DGSTAT)]"":DGSTAT,1:"U")
-	S DGDATE=$G(DGDATE)
-	S DGPROV=$G(DGPROV)
-	S DGSITE=$G(DGSITE)
-	S DGXMIT=$S($G(DGXMIT)=0:DGXMIT,1:1)
-	S DGDATE=$S(+DGDATE>0:DGDATE,1:$$NOW^XLFDT)
-	S DGSITE=$S(+DGSITE>0:DGSITE,1:$$SITE)
-	;
-	I '$$CHANGE(DFN,DGSTAT,DGDATE) D  G NEWQ
-	. S DGRSLT="0"
-	;
-	I '$$VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,.DGERR) D  G NEWQ
-	. S DGRSLT="-1^"_DGERR
-	;
-	S DGFDA(1,29.11,"+1,",.01)=DGDATE
-	S DGFDA(1,29.11,"+1,",2)=DFN
-	S DGFDA(1,29.11,"+1,",3)=DGSTAT
-	S DGFDA(1,29.11,"+1,",4)=DGPROV
-	S DGFDA(1,29.11,"+1,",5)=DUZ
-	S DGFDA(1,29.11,"+1,",6)=DGSITE
-	;
-	D UPDATE^DIE("","DGFDA(1)","MSTIEN","DGERR")
-	I $D(DGERR) D  G NEWQ
-	. S DGRSLT="-1^"_$G(DGERR("DIERR",1))
-	;
-	S DGRSLT=+MSTIEN(1)
-	;
-	; Callpoint to queue an entry that will trigger a HEC
-	;  Enrollment Full Data Transmission (ORF/ORU~ZO7) HL7 message.
-	; The HL7 message will contain the following three MST data elments
-	;  as part of the VA-Specific Eligibility ZEL segment:
-	;   (23) - MST STATUS
-	;   (24) - DATE MST STATUS CHANGED
-	;   (25) - SITE DETERMINING MST STATUS
-	;
-	I DGXMIT D
-	. D SEND^DGMSTL1(DFN,"Z07")
-	;
-NEWQ	Q $G(DGRSLT)
-	;
-DELMST(MSTIEN)	; Deletes the MST HISTORY File (#29.11) entry passed in.
-	; This call is not to be used except from inside the DG MST List
-	; Manager interface.
-	;
-	; Input
-	;    MSTIEN   - IEN of the entry in the MST HISTORY File (#29.11)
-	;
-	; Output
-	;    If no IEN passed in, return -1
-	;    otherwise return 1
-	;
-	Q:'$G(MSTIEN) "-1^No entry to delete"
-	;
-	N DA,XD
-	S DA=+$G(MSTIEN)
-	S DIK="^DGMS(29.11,"
-	D ^DIK K DIK
-	Q 1
-	;
-NAME(DA)	; Returns name from the VA NEW PERSON File using DIQ call
-	;
-	N DGNAME,DGPROV,DIQ,DR,DIC
-	I $G(DA)="" G NAMEQ
-	S DIC=200,DR=".01",DIQ="DGPROV"
-	D EN^DIQ1
-	S DGNAME=$G(DGPROV(200,DA,.01))
-NAMEQ	Q $G(DGNAME)
-	;
-CHANGE(DFN,DGSTAT,DGDATE)	;Did the Status OR Date change?
-	;  Input
-	;      DFN    - Patients DFN
-	;      DGSTAT - MST Status code, "Y,N,D,U"
-	;      DGDATE - Date of MST Status Change (FM format)
-	;
-	;  Output
-	;      Returns 0 if no status change
-	;              1 if status changed
-	;
-	N DGCHG,DGMST
-	S DGCHG=0
-	I +$G(DFN)'>0!('$D(^DPT(DFN,0))) G CHNGQ
-	S DGSTAT=$G(DGSTAT)
-	I DGSTAT'?1A!("YNDU"'[DGSTAT) G CHNGQ
-	S DGDATE=$G(DGDATE)
-	I DGDATE="" G CHNGQ
-	S DGMST=$$GETSTAT(DFN),DGMST=$G(DGMST)
-	I +DGMST<1!($P(DGMST,U,2)'=$G(DGSTAT))!($P(DGMST,U,3)'=$G(DGDATE)) S DGCHG=1
-CHNGQ	Q DGCHG
-	;
-SITE(DGSITE)	;Convert a station number into a pointer to the
-	; INSTITUTION file (#4).  If called with a null parameter then
-	; the pointer to the INSTITUTION file (#4) of the primary site
-	; will be returned.
-	;
-	;  Input
-	;    DGSITE - Station number (optional)
-	;
-	;  Output
-	;    Return Site IEN to INSTITUTION file (#4)
-	;
-	S DGSITE=$G(DGSITE)
-	I DGSITE]"",$D(^DIC(4,"D",DGSITE)) D
-	. S DGSITE=$O(^DIC(4,"D",DGSITE,0))
-	E  D
-	. S DGSITE=$P($$SITE^VASITE,U)
-	I +DGSITE'>0 S DGSITE=""
-	Q DGSITE
-	;
-DATE(DFN,DGDT)	;Determine 'current' MST date
-	;
-	;  Input
-	;    DFN  - Patient's DFN
-	;    DGDT - FileMan format date
-	;
-	;  Output
-	;    Return MST effective date
-	;
-	N DGMSTDT
-	S DFN=$G(DFN)
-	I '+DFN D  G DATEQ
-	. S DGMSTDT=""
-	S DGDT=$S(+$G(DGDT)>0:DGDT,1:$$NOW^XLFDT)
-	I $P(DGDT,".",2)="" S DGDT=DGDT_".999999"
-	S DGMSTDT=$O(^DGMS(29.11,"APDT",DFN,DGDT),-1)
-DATEQ	Q DGMSTDT
-	;
-VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGERR)	;Validate fields before filing
-	; Input:
-	;      DFN - [REQUIRED] - ien of Patient
-	;   DGSTAT - [REQUIRED] - MST Status code, "Y,N,D,U"
-	;   DGDATE - [REQUIRED] - Date of MST status change[FileMan Internal]
-	;   DGPROV - [optional] - IEN of Provider making determination
-	;   DGSITE - [optional] - IEN pointer of the INSTITUTION file
-	;    DGERR - [optional] - error parameter passed by reference
-	; Output:
-	;   Function Value - Returns 1 - if validation checks passed
-	;                            0 - if validation checks failed
-	;            DGERR - an error message if validation checks fail
-	; init variables
-	N I,DGFILE,DGFLD,DGMSG,DGSTR,DGVAL,DGVAR,DGX,VALID
-	S DGFILE=29.11,VALID=1,DGMSG=" IS REQUIRED"
-	; Quit DO block if invalid condition found
-	; Check for [REQUIRED] fields
-	D
-	. I DFN="" D MSG(DGFILE,2,DGMSG,.DGERR) Q        ;pat ien
-	. I DGSTAT="" D MSG(DGFILE,3,DGMSG,.DGERR) Q     ;mst status code
-	. I DGDATE="" D MSG(DGFILE,.01,DGMSG,.DGERR) Q   ;dt chg status
-	.;
-	.; Check for valid FIELD values
-	. S DGMSG=" IS NOT VALID"
-	.; need to strip off the 'seconds' to pass the CHK^DIE() call...
-	. I DGDATE["." N DGSECS S DGSECS=$E($P(DGDATE,".",2),5,6) I DGSECS'="" I DGSECS<0!(DGSECS>60) D MSG(DGFILE,.01,DGMSG,.DGERR) Q
-	. N DGDATEX S DGDATEX=DGDATE
-	. I DGDATEX["." S DGDATEX=$P(DGDATEX,".")_"."_$E($P(DGDATEX,".",2),1,4)
-	. I $E($P(DGDATEX,".",2),1,4)="0000" S DGDATEX=$P(DGDATEX,".")_".1"
-	. S DGSTR=".01;DGDATEX^2;DFN^3;DGSTAT^4;DGPROV^5;DUZ^6;DGSITE"
-	.;
-	. F I=1:1:$L(DGSTR,U) S DGX=$P(DGSTR,U,I) Q:DGX=""  D  Q:'VALID
-	.. S DGFLD=$P(DGX,";"),DGVAR=$P(DGX,";",2),DGVAL=@DGVAR
-	.. Q:DGVAL=""
-	.. S VALID=$$TESTVAL(DGFILE,DGFLD,DGVAL)
-	.. D:'VALID MSG(DGFILE,DGFLD,DGMSG,.DGERR)
-	Q VALID
-	;
-MSG(DGFIL,DGFLD,DGMSG,DGERR)	; error message setup
-	; Input:
-	;   DGFIL - file number
-	;   DGFLD - field number of file
-	;   DGMSG - message type verbiage - " IS REQUIRED" or " IS NOT VALID"
-	;   DGERR - error parameter passed by reference
-	; Output:
-	;   DGERR - error message
-	S DGERR=$$GET1^DID(DGFIL,DGFLD,,"LABEL")_DGMSG
-	Q
-	;
-TESTVAL(DGFIL,DGFLD,DGVAL)	; Determine if a field value is valid.
-	; Input:
-	;   DGFIL - file number
-	;   DGFLD - field number of file
-	;   DGVAL - field value to be validated
-	; Output:
-	;   Function value: Returns 1 if field is valid
-	;                           0 if validation fails
-	N DGVALEX,DGRSLT,VALID
-	S VALID=1
-	I DGVAL'="" D
-	. S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
-	. I DGVALEX="" S VALID=0 Q   ; no external value, not valid
-	. I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'="POINTER" D
-	.. D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0
-	Q VALID
+DGMSTAPI ;ALB/SCK - API's for Military Sexual Trauma ;7:34 PM  30 Jan 2008
+ ;;5.3;Registration;**195,243,308,353,379,443,700,VWEHR1**;WorldVistA 30-Jan-08
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ Q
+ ;
+GETSTAT(DFN,DGDATE) ;  Retrieves the current MST status for a patient
+ ;
+ ;  Input
+ ;    DFN  - IEN of patient in the PATIENT File (#2)
+ ;    DGDATE - Date for status lookup [OPTIONAL]
+ ;
+ ;  Output
+ ;    DGMST - Format will depend on result of lookup
+ ;
+ ;    If an entry is found then:
+ ;       DGMST returns a 7 piece data string, caret(^)-delimited:
+ ;        $P(1) = IEN of entry in MST HISTORY File (#29.11)
+ ;        $P(2) = Internal value of MST Status ("Y,N,D,U")
+ ;        $P(3) = Date of status change
+ ;        $P(4) = IEN of provider making determination, file (#200)
+ ;        $P(5) = IEN of user who entered status, file (#200)
+ ;        $P(6) = External format of MST Status
+ ;        $P(7) = IEN pointer of the INSTITUTION file (#4)
+ ;
+ ;    If no MST History is found, then:
+ ;       DGMST = 0^U
+ ;                "U" = (Unknown)
+ ;    If an error occured in the GETS^DIQ lookup, then:
+ ;       DGMST = -1^^Error Code IEN
+ ;                   (returned by GETS^DIQ call)
+ ;
+ ; Get most recent MST status entry for the patient from file using
+ ;  reverse $Order on the "APDT" x-ref.
+ ;
+ N DGMST,DGIEN,DGFDA,DGMSG
+ S DFN=$G(DFN)
+ I '+DFN!('$D(^DPT(DFN,0))) D  G STATQ
+ . S DGMST="-1"
+ I '$D(^DGMS(29.11,"APDT",DFN))  D  G STATQ
+ .S DGMST="0^U"
+ S DGDATE=$S(+$G(DGDATE)>0:DGDATE,1:$$NOW^XLFDT)
+ I '$D(^DGMS(29.11,"APDT",DFN,DGDATE)) S DGDATE=$$DATE(DFN,DGDATE)
+ I '+DGDATE D  G STATQ
+ . S DGMST="0^U"
+ S DGIEN=""
+ ;
+ ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ ;
+ ;S DGIEN=+$P($Q(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1),",",5)
+ S DGIEN=+$P($$Q^VWUTIL($NA(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN)),-1),",",5)
+ ;
+ ;END CHANGE
+ ;
+ ; Check for valid ien, if entry missing, return Unknown
+ I +DGIEN'>0 D  G STATQ
+ . S DGMST="0^U"
+ ;
+ ; Retrieve data
+ D GETS^DIQ(29.11,+DGIEN_",","*","IE","DGFDA","DGMSG")
+ ; check for errors
+ I $D(DGMSG) D  G STATQ
+ .S DGMST="-1^^"_$G(DGMSG("DIERR",1))
+ ;
+ S DGMST=DGIEN_U_$G(DGFDA(29.11,+DGIEN_",",3,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",.01,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",4,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",5,"I"))
+ S DGMST=DGMST_U_$G(DGFDA(29.11,+DGIEN_",",3,"E"))
+ S DGMST=DGMST_U_$S($G(DGFDA(29.11,+DGIEN_",",6,"I"))]"":$G(DGFDA(29.11,+DGIEN_",",6,"I")),1:$$SITE)
+ ;
+STATQ Q $G(DGMST)
+ ;
+NEWSTAT(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGXMIT) ; MST HISTORY (#29.11) filer
+ ; Callpoint to create a new MST HISTORY FILE (#29.11) entry.
+ ; Will also queue HL7 message for HEC database updates.
+ ;
+ ;  Input
+ ;    DFN    - Patients DFN
+ ;    DGSTAT - MST Status code, "Y,N,D,U"
+ ;    DGDATE - Date of MST status change  [default=NOW]
+ ;    DGPROV - IEN of Provider making determination, file (#200)
+ ;    DGSITE - IEN pointer of the INSTITUTION file (#4)
+ ;    DGXMIT - HL7 transmit flag [OPTIONAL]
+ ;              0=don't queue a message
+ ;              1=queue a message [default])
+ ;
+ ;  Output
+ ;    DGRSLT - Returns IEN of file (#29.11) entry if successful
+ ;
+ ;    If no patient was defined, then:
+ ;       DGRSLT = -1^No patient defined
+ ;
+ ;    If an error occured in the GETS^DIQ lookup, then:
+ ;       DGMST = -1^^Error Code IEN
+ ;                   (returned by GETS^DIQ call)
+ ;
+ N DGFDA,DGMSG,DGERR,DGRSLT,MSTIEN
+ S DFN=$G(DFN)
+ I DFN']""!('$D(^DPT(DFN,0))) D  G NEWQ
+ . S DGRSLT="-1^No patient defined"
+ ;
+ S DGSTAT=$S($G(DGSTAT)]"":DGSTAT,1:"U")
+ S DGDATE=$G(DGDATE)
+ S DGPROV=$G(DGPROV)
+ S DGSITE=$G(DGSITE)
+ S DGXMIT=$S($G(DGXMIT)=0:DGXMIT,1:1)
+ S DGDATE=$S(+DGDATE>0:DGDATE,1:$$NOW^XLFDT)
+ S DGSITE=$S(+DGSITE>0:DGSITE,1:$$SITE)
+ ;
+ I '$$CHANGE(DFN,DGSTAT,DGDATE) D  G NEWQ
+ . S DGRSLT="0"
+ ;
+ I '$$VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,.DGERR) D  G NEWQ
+ . S DGRSLT="-1^"_DGERR
+ ;
+ S DGFDA(1,29.11,"+1,",.01)=DGDATE
+ S DGFDA(1,29.11,"+1,",2)=DFN
+ S DGFDA(1,29.11,"+1,",3)=DGSTAT
+ S DGFDA(1,29.11,"+1,",4)=DGPROV
+ S DGFDA(1,29.11,"+1,",5)=DUZ
+ S DGFDA(1,29.11,"+1,",6)=DGSITE
+ ;
+ D UPDATE^DIE("","DGFDA(1)","MSTIEN","DGERR")
+ I $D(DGERR) D  G NEWQ
+ . S DGRSLT="-1^"_$G(DGERR("DIERR",1))
+ ;
+ S DGRSLT=+MSTIEN(1)
+ ;
+ ; Callpoint to queue an entry that will trigger a HEC
+ ;  Enrollment Full Data Transmission (ORF/ORU~ZO7) HL7 message.
+ ; The HL7 message will contain the following three MST data elments
+ ;  as part of the VA-Specific Eligibility ZEL segment:
+ ;   (23) - MST STATUS
+ ;   (24) - DATE MST STATUS CHANGED
+ ;   (25) - SITE DETERMINING MST STATUS
+ ;
+ I DGXMIT D
+ . D SEND^DGMSTL1(DFN,"Z07")
+ ;
+NEWQ Q $G(DGRSLT)
+ ;
+DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in.
+ ; This call is not to be used except from inside the DG MST List
+ ; Manager interface.
+ ;
+ ; Input
+ ;    MSTIEN   - IEN of the entry in the MST HISTORY File (#29.11)
+ ;
+ ; Output
+ ;    If no IEN passed in, return -1
+ ;    otherwise return 1
+ ;
+ Q:'$G(MSTIEN) "-1^No entry to delete"
+ ;
+ N DA,XD
+ S DA=+$G(MSTIEN)
+ S DIK="^DGMS(29.11,"
+ D ^DIK K DIK
+ Q 1
+ ;
+NAME(DA) ; Returns name from the VA NEW PERSON File using DIQ call
+ ;
+ N DGNAME,DGPROV,DIQ,DR,DIC
+ I $G(DA)="" G NAMEQ
+ S DIC=200,DR=".01",DIQ="DGPROV"
+ D EN^DIQ1
+ S DGNAME=$G(DGPROV(200,DA,.01))
+NAMEQ Q $G(DGNAME)
+ ;
+CHANGE(DFN,DGSTAT,DGDATE) ;Did the Status OR Date change?
+ ;  Input
+ ;      DFN    - Patients DFN
+ ;      DGSTAT - MST Status code, "Y,N,D,U"
+ ;      DGDATE - Date of MST Status Change (FM format)
+ ;
+ ;  Output
+ ;      Returns 0 if no status change
+ ;              1 if status changed
+ ;
+ N DGCHG,DGMST
+ S DGCHG=0
+ I +$G(DFN)'>0!('$D(^DPT(DFN,0))) G CHNGQ
+ S DGSTAT=$G(DGSTAT)
+ I DGSTAT'?1A!("YNDU"'[DGSTAT) G CHNGQ
+ S DGDATE=$G(DGDATE)
+ I DGDATE="" G CHNGQ
+ S DGMST=$$GETSTAT(DFN),DGMST=$G(DGMST)
+ I +DGMST<1!($P(DGMST,U,2)'=$G(DGSTAT))!($P(DGMST,U,3)'=$G(DGDATE)) S DGCHG=1
+CHNGQ Q DGCHG
+ ;
+SITE(DGSITE) ;Convert a station number into a pointer to the
+ ; INSTITUTION file (#4).  If called with a null parameter then
+ ; the pointer to the INSTITUTION file (#4) of the primary site
+ ; will be returned.
+ ;
+ ;  Input
+ ;    DGSITE - Station number (optional)
+ ;
+ ;  Output
+ ;    Return Site IEN to INSTITUTION file (#4)
+ ;
+ S DGSITE=$G(DGSITE)
+ I DGSITE]"",$D(^DIC(4,"D",DGSITE)) D
+ . S DGSITE=$O(^DIC(4,"D",DGSITE,0))
+ E  D
+ . S DGSITE=$P($$SITE^VASITE,U)
+ I +DGSITE'>0 S DGSITE=""
+ Q DGSITE
+ ;
+DATE(DFN,DGDT) ;Determine 'current' MST date
+ ;
+ ;  Input
+ ;    DFN  - Patient's DFN
+ ;    DGDT - FileMan format date
+ ;
+ ;  Output
+ ;    Return MST effective date
+ ;
+ N DGMSTDT
+ S DFN=$G(DFN)
+ I '+DFN D  G DATEQ
+ . S DGMSTDT=""
+ S DGDT=$S(+$G(DGDT)>0:DGDT,1:$$NOW^XLFDT)
+ I $P(DGDT,".",2)="" S DGDT=DGDT_".999999"
+ S DGMSTDT=$O(^DGMS(29.11,"APDT",DFN,DGDT),-1)
+DATEQ Q DGMSTDT
+ ;
+VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGERR) ;Validate fields before filing
+ ; Input:
+ ;      DFN - [REQUIRED] - ien of Patient
+ ;   DGSTAT - [REQUIRED] - MST Status code, "Y,N,D,U"
+ ;   DGDATE - [REQUIRED] - Date of MST status change[FileMan Internal]
+ ;   DGPROV - [optional] - IEN of Provider making determination
+ ;   DGSITE - [optional] - IEN pointer of the INSTITUTION file
+ ;    DGERR - [optional] - error parameter passed by reference
+ ; Output:
+ ;   Function Value - Returns 1 - if validation checks passed
+ ;                            0 - if validation checks failed
+ ;            DGERR - an error message if validation checks fail
+ ; init variables
+ N I,DGFILE,DGFLD,DGMSG,DGSTR,DGVAL,DGVAR,DGX,VALID
+ S DGFILE=29.11,VALID=1,DGMSG=" IS REQUIRED"
+ ; Quit DO block if invalid condition found
+ ; Check for [REQUIRED] fields
+ D
+ . I DFN="" D MSG(DGFILE,2,DGMSG,.DGERR) Q        ;pat ien
+ . I DGSTAT="" D MSG(DGFILE,3,DGMSG,.DGERR) Q     ;mst status code
+ . I DGDATE="" D MSG(DGFILE,.01,DGMSG,.DGERR) Q   ;dt chg status
+ .;
+ .; Check for valid FIELD values
+ . S DGMSG=" IS NOT VALID"
+ .; need to strip off the 'seconds' to pass the CHK^DIE() call...
+ . I DGDATE["." N DGSECS S DGSECS=$E($P(DGDATE,".",2),5,6) I DGSECS'="" I DGSECS<0!(DGSECS>60) D MSG(DGFILE,.01,DGMSG,.DGERR) Q
+ . N DGDATEX S DGDATEX=DGDATE
+ . I DGDATEX["." S DGDATEX=$P(DGDATEX,".")_"."_$E($P(DGDATEX,".",2),1,4)
+ . I $E($P(DGDATEX,".",2),1,4)="0000" S DGDATEX=$P(DGDATEX,".")_".1"
+ . S DGSTR=".01;DGDATEX^2;DFN^3;DGSTAT^4;DGPROV^5;DUZ^6;DGSITE"
+ .;
+ . F I=1:1:$L(DGSTR,U) S DGX=$P(DGSTR,U,I) Q:DGX=""  D  Q:'VALID
+ .. S DGFLD=$P(DGX,";"),DGVAR=$P(DGX,";",2),DGVAL=@DGVAR
+ .. Q:DGVAL=""
+ .. S VALID=$$TESTVAL(DGFILE,DGFLD,DGVAL)
+ .. D:'VALID MSG(DGFILE,DGFLD,DGMSG,.DGERR)
+ Q VALID
+ ;
+MSG(DGFIL,DGFLD,DGMSG,DGERR) ; error message setup
+ ; Input:
+ ;   DGFIL - file number
+ ;   DGFLD - field number of file
+ ;   DGMSG - message type verbiage - " IS REQUIRED" or " IS NOT VALID"
+ ;   DGERR - error parameter passed by reference
+ ; Output:
+ ;   DGERR - error message
+ S DGERR=$$GET1^DID(DGFIL,DGFLD,,"LABEL")_DGMSG
+ Q
+ ;
+TESTVAL(DGFIL,DGFLD,DGVAL) ; Determine if a field value is valid.
+ ; Input:
+ ;   DGFIL - file number
+ ;   DGFLD - field number of file
+ ;   DGVAL - field value to be validated
+ ; Output:
+ ;   Function value: Returns 1 if field is valid
+ ;                           0 if validation fails
+ N DGVALEX,DGRSLT,VALID
+ S VALID=1
+ I DGVAL'="" D
+ . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
+ . I DGVALEX="" S VALID=0 Q   ; no external value, not valid
+ . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'="POINTER" D
+ .. D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0
+ Q VALID
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTCOU1.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTCOU1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTCOU1.m	(revision 623)
@@ -1,115 +1,115 @@
-DGMTCOU1	;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ;11/5/06  20:29
-	;;5.3;Registration;**33,45,54,335,358,401,436,445,564,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-AUTO(DFN,AUTOEX)	;
-	; Returns 1 if Exempt from CP w/o needing MT/CP information
-	;  INPUT: DFN     [Required]
-	;         AUTOEX  [Optional]
-	;  RETURNS 1=Exempt 0=Not Exempt
-	;
-	; Hold the Auto exclusion information for later use
-	S AUTOEX=$$AUTOINFO(DFN)
-	;
-	Q AUTOEX["1"
-AUTOINFO(DFN)	;
-	; This returns info needed to IB to see if MT information needs to be
-	; looked at to determine Copay Exemption Status
-	;
-	;  INPUT: DFN - IEN of Patient File (Required)
-	; OUTPUT: (SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PT^NON.VET^INPT^POW^UNEMP)
-	;  Piece: (   1  ^   2   ^   3  ^   4   ^   5  ^   6   ^  7 ^ 8 ^  9  )
-	;  PIECES =1 IF TRUE
-	;
-	N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT,DGI
-	S DGX=""
-	I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S $P(DGX,U,6)=1 G QTAUTO ;NON-VET
-	S DGEL=0,DGALLEL=U
-	F  S DGEL=$O(^DPT("AEL",DFN,DGEL)) Q:'DGEL  S DGALLEL=DGALLEL_$P($G(^DIC(8,DGEL,0)),U,9)_U
-	F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI))
-	I (DGALLEL["^1^") S $P(DGX,U,1)=1 G QTAUTO ;SC>50
-	I $P(DGNODE(.362),U,12)["Y"!(DGALLEL["^2^") S $P(DGX,U,2)=1 G QTAUTO ;A&A
-	I $P(DGNODE(.362),U,13)["Y"!(DGALLEL["^15^") S $P(DGX,U,3)=1 G QTAUTO ;HB
-	I $P(DGNODE(.362),U,14)["Y"!(DGALLEL["^4^") S $P(DGX,U,4)=1 G QTAUTO ;PENSION
-	I $P(DGNODE(.52),U,5)["Y"!(DGALLEL["^18^") S $P(DGX,U,8)=1 G QTAUTO ;POW
-	I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S $P(DGX,U,9)=1 G QTAUTO ;UNEMPLOYABLE
-	N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
-	D DOM^DGMTR I $G(DGDOM) S $P(DGX,U,5)=1 G QTAUTO ;DOM
-	D IN5^VADPT I $G(VAIP(1))'="" S $P(DGX,U,7)=1 G QTAUTO ;INPAT
-QTAUTO	Q DGX
-	;
-LST(DFN,DGDT,DGMTYPT1)	;Last Copay Exemption or Means Test for a patient
-	;   Input  -- DFN   Patient IEN
-	;             DGDT  Date/Time  (Optional- default today@2359)
-	;             DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
-	;   Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
-	;      Piece:   1   ^     2              3         4            5
-	;
-	N DGCPDT,DGIDT,DGIDT,DGMTDT,DGMTI,Y
-	S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
-	I '$D(DGMTYPT1) S DGMTYPT1=3
-	I DGMTYPT1=3 D  ;EITHER
-	.S DGMTDT=+$O(^DGMT(408.31,"AID",1,DFN,DGIDT))
-	.S DGCPDT=+$O(^DGMT(408.31,"AID",2,DFN,DGIDT))
-	.S DGMTYPT1=$S(DGCPDT<DGMTDT:2,(DGCPDT>DGMTDT):1,$D(^DGMT(408.31,"AS",1,3,+DGMTDT,DFN)):2,1:1)
-	S DGMTI=+$$LST^DGMTU(DFN,$P(DGIDT,"-",2),DGMTYPT1)
-	I $D(^DGMT(408.31,DGMTI,0)) S Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS^DGMTU(DFN,+$P(^(0),"^",3))_"^"_DGMTYPT1
-	Q $G(Y)
-THRESH(DGDT)	;PRINTS THE YEAR'S COPAY THRESHOLDS
-	;UPDATE 11/15/00 TO REFLECT YEAR'S COPAY THRESHOLDS PER VHA DIRECTIVE
-	;99-064
-	N DGCPLEV,DGDEP,DGNODE,DGTYPE,Y
-	I '$D(DGDT) S DGDT=DT
-	S DGDT=DGDT\1
-	S Y=DGDT X ^DD("DD") W !,?2,"Net Annual Income Thresholds on ",Y,":"
-	S DGTYPE=$S(DGDT<2961201:2,1:1)
-	S DGCPLEV=$$THRES^IBARXEU1(DGDT,DGTYPE,0)
-	I DGCPLEV']"" W !,"None for this date..." G THRESHQT
-	W !,?5,"Num. Dependents: ",?25,"0 (Self)",?42,1,?52,2,?62,3,?72,4
-	W !,?5,"Net Income:"
-	F DGDEP=0:1:4 W ?(23+(DGDEP*10)),$J(+$$THRES^IBARXEU1(DGDT,DGTYPE,DGDEP),10)
-THRESHQT	Q
-DISPMAS(DFN)	; Displays Co
-	;New EHR code    ;DAOU/JLG 2/4/05
-	;not relevant to Agency EHR
-	Q:$G(DUZ("AG"))="E"
-	;End EHR modifications
-	N DGCPS,DGEX,Y,AUTOEX
-	S DGEX=$$AUTO(DFN,.AUTOEX)
-	I $P($G(AUTOEX),U,5)!($P($G(AUTOEX),U,7)) Q
-	I DGEX W !,"Patient is exempt from Copay."
-	I 'DGEX D
-	.S DGCPS=$$LST365(DFN,DT,2),Y=$P(DGCPS,U,2)
-	.I DGCPS]"" D
-	..X ^DD("DD")
-	..W !,"Patient's Copay Status is ",$P(DGCPS,U,3)
-	..W ".  Last Test Date: ",Y,"."
-	Q
-LST365(DFN,DGDT,DGMTYPT1)	;RETURNS CURRENT MT/CP  (WITHIN 365 DAYS)
-	;  Input:   DGDT - IB DATE
-	;           DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
-	;  Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
-	;     Piece:   1   ^     2              3         4            5
-	N DGLST
-	S DGDT=$G(DGDT)
-	I '$D(DGMTYPT1) S DGMTYPT1=3
-	S DGLST=$$LST(DFN,DGDT,DGMTYPT1)
-	S:$P(DGLST,U,4)="N" DGLST=$$LST(DFN,DGDT,2)
-	S:$$365($P(DGLST,U,2),DGDT) DGLST="" ;RETURN NULL IF LAST >365
-	Q DGLST
-365(X1,DGDT)	; RETURNS 1 IF X1 IS MORE THAN 1 YEAR BEFORE DGDT
-	Q X1+10000'>DGDT
+DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ;11/5/06  20:29
+ ;;5.3;Registration;**33,45,54,335,358,401,436,445,564,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+AUTO(DFN,AUTOEX) ;
+ ; Returns 1 if Exempt from CP w/o needing MT/CP information
+ ;  INPUT: DFN     [Required]
+ ;         AUTOEX  [Optional]
+ ;  RETURNS 1=Exempt 0=Not Exempt
+ ;
+ ; Hold the Auto exclusion information for later use
+ S AUTOEX=$$AUTOINFO(DFN)
+ ;
+ Q AUTOEX["1"
+AUTOINFO(DFN) ;
+ ; This returns info needed to IB to see if MT information needs to be
+ ; looked at to determine Copay Exemption Status
+ ;
+ ;  INPUT: DFN - IEN of Patient File (Required)
+ ; OUTPUT: (SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PT^NON.VET^INPT^POW^UNEMP)
+ ;  Piece: (   1  ^   2   ^   3  ^   4   ^   5  ^   6   ^  7 ^ 8 ^  9  )
+ ;  PIECES =1 IF TRUE
+ ;
+ N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT,DGI
+ S DGX=""
+ I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S $P(DGX,U,6)=1 G QTAUTO ;NON-VET
+ S DGEL=0,DGALLEL=U
+ F  S DGEL=$O(^DPT("AEL",DFN,DGEL)) Q:'DGEL  S DGALLEL=DGALLEL_$P($G(^DIC(8,DGEL,0)),U,9)_U
+ F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI))
+ I (DGALLEL["^1^") S $P(DGX,U,1)=1 G QTAUTO ;SC>50
+ I $P(DGNODE(.362),U,12)["Y"!(DGALLEL["^2^") S $P(DGX,U,2)=1 G QTAUTO ;A&A
+ I $P(DGNODE(.362),U,13)["Y"!(DGALLEL["^15^") S $P(DGX,U,3)=1 G QTAUTO ;HB
+ I $P(DGNODE(.362),U,14)["Y"!(DGALLEL["^4^") S $P(DGX,U,4)=1 G QTAUTO ;PENSION
+ I $P(DGNODE(.52),U,5)["Y"!(DGALLEL["^18^") S $P(DGX,U,8)=1 G QTAUTO ;POW
+ I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S $P(DGX,U,9)=1 G QTAUTO ;UNEMPLOYABLE
+ N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
+ D DOM^DGMTR I $G(DGDOM) S $P(DGX,U,5)=1 G QTAUTO ;DOM
+ D IN5^VADPT I $G(VAIP(1))'="" S $P(DGX,U,7)=1 G QTAUTO ;INPAT
+QTAUTO Q DGX
+ ;
+LST(DFN,DGDT,DGMTYPT1) ;Last Copay Exemption or Means Test for a patient
+ ;   Input  -- DFN   Patient IEN
+ ;             DGDT  Date/Time  (Optional- default today@2359)
+ ;             DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
+ ;   Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
+ ;      Piece:   1   ^     2              3         4            5
+ ;
+ N DGCPDT,DGIDT,DGIDT,DGMTDT,DGMTI,Y
+ S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
+ I '$D(DGMTYPT1) S DGMTYPT1=3
+ I DGMTYPT1=3 D  ;EITHER
+ .S DGMTDT=+$O(^DGMT(408.31,"AID",1,DFN,DGIDT))
+ .S DGCPDT=+$O(^DGMT(408.31,"AID",2,DFN,DGIDT))
+ .S DGMTYPT1=$S(DGCPDT<DGMTDT:2,(DGCPDT>DGMTDT):1,$D(^DGMT(408.31,"AS",1,3,+DGMTDT,DFN)):2,1:1)
+ S DGMTI=+$$LST^DGMTU(DFN,$P(DGIDT,"-",2),DGMTYPT1)
+ I $D(^DGMT(408.31,DGMTI,0)) S Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS^DGMTU(DFN,+$P(^(0),"^",3))_"^"_DGMTYPT1
+ Q $G(Y)
+THRESH(DGDT) ;PRINTS THE YEAR'S COPAY THRESHOLDS
+ ;UPDATE 11/15/00 TO REFLECT YEAR'S COPAY THRESHOLDS PER VHA DIRECTIVE
+ ;99-064
+ N DGCPLEV,DGDEP,DGNODE,DGTYPE,Y
+ I '$D(DGDT) S DGDT=DT
+ S DGDT=DGDT\1
+ S Y=DGDT X ^DD("DD") W !,?2,"Net Annual Income Thresholds on ",Y,":"
+ S DGTYPE=$S(DGDT<2961201:2,1:1)
+ S DGCPLEV=$$THRES^IBARXEU1(DGDT,DGTYPE,0)
+ I DGCPLEV']"" W !,"None for this date..." G THRESHQT
+ W !,?5,"Num. Dependents: ",?25,"0 (Self)",?42,1,?52,2,?62,3,?72,4
+ W !,?5,"Net Income:"
+ F DGDEP=0:1:4 W ?(23+(DGDEP*10)),$J(+$$THRES^IBARXEU1(DGDT,DGTYPE,DGDEP),10)
+THRESHQT Q
+DISPMAS(DFN) ; Displays Co
+ ;New EHR code    ;DAOU/JLG 2/4/05
+ ;not relevant to Agency EHR
+ Q:$G(DUZ("AG"))="E"
+ ;End EHR modifications
+ N DGCPS,DGEX,Y,AUTOEX
+ S DGEX=$$AUTO(DFN,.AUTOEX)
+ I $P($G(AUTOEX),U,5)!($P($G(AUTOEX),U,7)) Q
+ I DGEX W !,"Patient is exempt from Copay."
+ I 'DGEX D
+ .S DGCPS=$$LST365(DFN,DT,2),Y=$P(DGCPS,U,2)
+ .I DGCPS]"" D
+ ..X ^DD("DD")
+ ..W !,"Patient's Copay Status is ",$P(DGCPS,U,3)
+ ..W ".  Last Test Date: ",Y,"."
+ Q
+LST365(DFN,DGDT,DGMTYPT1) ;RETURNS CURRENT MT/CP  (WITHIN 365 DAYS)
+ ;  Input:   DGDT - IB DATE
+ ;           DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
+ ;  Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
+ ;     Piece:   1   ^     2              3         4            5
+ N DGLST
+ S DGDT=$G(DGDT)
+ I '$D(DGMTYPT1) S DGMTYPT1=3
+ S DGLST=$$LST(DFN,DGDT,DGMTYPT1)
+ S:$P(DGLST,U,4)="N" DGLST=$$LST(DFN,DGDT,2)
+ S:$$365($P(DGLST,U,2),DGDT) DGLST="" ;RETURN NULL IF LAST >365
+ Q DGLST
+365(X1,DGDT) ; RETURNS 1 IF X1 IS MORE THAN 1 YEAR BEFORE DGDT
+ Q X1+10000'>DGDT
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTU.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTU.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTU.m	(revision 623)
@@ -1,205 +1,205 @@
-DGMTU	;ALB/RMO,LBD,BRM,EG - Means Test Utilities ; 02/08/2005 07:10 AM
-	;;5.3;Registration;**4,33,182,277,290,374,358,420,426,411,332,433,456,476,519,451,630,783**;Aug 13, 1993;Build 2
-	;MT=Means Test
-LST(DFN,DGDT,DGMTYPT)	;Last MT for a patient
-	;         Input  -- DFN   Patient IEN
-	;                   DGDT  Date/Time  (Optional- default today@2359)
-	;                DGMTYPT  Type of Test (Optional - if not defined 
-	;                                       Means Test will be assumed)
-	;         Output -- Annual Means Test IEN^Date of Test
-	;                   ^Status Name^Status Code^Source of Test
-	N DGIDT,DGMTFL1,DGMTI,DGNOD,Y I '$D(DGMTYPT) S DGMTYPT=1
-	S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
-	F  S DGIDT=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT)) Q:'DGIDT!$G(DGMTFL1)  D
-	.F DGMTI=0:0 S DGMTI=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT,DGMTI)) Q:'DGMTI!$G(DGMTFL1)  D
-	..S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD,$G(^("PRIM"))!(DGMTYPT=4) S DGMTFL1=1,Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS(DFN,+$P(^(0),"^",3))_"^"_$P(DGNOD,"^",23) ; chk for primary MT
-	Q $G(Y)
-	;
-LVMT(DFN,DGDT)	;Last valid MT (status other than required)
-	;          Input  -- DFN    Patient IEN
-	;                    DGDT   Date (Optional - default today)
-	;          Output -- Annual Means Test IEN^Date of Test^Status Name
-	;                     ^Status Code
-	N DGMT,DGMTL
-	S:'$D(DGDT) DGDT=DT S DGMTL=$$LST^DGMTU(DFN,DGDT)
-	I $P(DGMTL,"^",4)="R" F  S DGMT=$$LST^DGMTU(DFN,DGDT) Q:DGMT']""!($P(DGMT,U,4)'="R")  S DGDT=$P(DGMT,U,2)-1
-	Q $S($G(DGMT)]"":DGMT,1:$G(DGMTL))
-	;
-NVMT(DFN,DGDT)	;Next valid MT (status other than required)
-	;          Input  -- DFN    Patient IEN
-	;                    DGDT   Date (Required)
-	;          Output -- Annual Means Test IEN^Date of Test^Status Name
-	;                     ^Status Code
-	N DGDTE,DGMT,DGMT0,DGMTI,DGMTPR,DGMTS
-	S DGDTE=DGDT
-	F  S DGDTE=$O(^DGMT(408.31,"AD",1,DFN,DGDTE)) Q:'DGDTE!$G(DGMT)  D
-	.F DGMTI=0:0 S DGMTI=$O(^DGMT(408.31,"AD",1,DFN,DGDTE,DGMTI)) Q:'DGMTI  S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTS=+$P(DGMT0,"^",3),DGMTPR=$G(^("PRIM")) I +DGMT0,DGMTS'=1,DGMTPR S DGMT=DGMTI_"^"_+DGMT0_"^"_$$MTS^DGMTU(DFN,DGMTS) Q
-	Q $G(DGMT)
-	;
-MTS(DFN,DGMTS)	;MT status -- default current
-	;         Input  -- DFN    Patient IEN
-	;                   DGMTS  Means Test Status IEN  (Optional)
-	;         Output -- Status Name^Status Code
-	N Y
-	S DGMTS=$S($G(DGMTS)>0:DGMTS,1:$P($G(^DPT(DFN,0)),"^",14))
-	I DGMTS S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2)
-	Q $G(Y)
-	;
-DIS(DFN)	;Display patients current MT status,
-	;        eligibility for care, deductible information,
-	;        date of test and date of completion
-	;         Input  -- DFN    Patient IEN
-	;         Output -- None
-	N DGCS,DGDED,DGMTI,DGMT0
-	S DGCS=$P($G(^DPT(DFN,0)),"^",14) G DISQ:DGCS=""
-	S DGMTI=+$$LST^DGMTU(DFN),DGMT0=$G(^DGMT(408.31,DGMTI,0))
-	S MTSIG=$P(DGMT0,"^",29)
-	W !,"Means Test Signed?: ",$S(MTSIG=1:"YES",MTSIG=0:"NO",MTSIG=9:"DELETED",1:"")
-	I DGCS=1 W !!,"Patient Requires a Means Test"
-	I DGCS=2 W !!,"Patient's Means Test is Pending Adjudication for "_$$PA^DGMTUTL(DGMTI)
-	I DGCS=3 W !!,"Means Test Not Required"
-	I ("^4^5^6^16^")[("^"_DGCS_"^") W !!,"Patient's status is ",$$GETNAME^DGMTH(DGCS)," based on primary means test"
-	I $D(^DG(408.32,DGCS,"MSG")) W !,^("MSG")
-	I DGCS=6 S DGDED=$P(DGMT0,"^",11) W ! W:DGDED]"" "Has",$S(DGDED:"",1:" not")," agreed to pay the deductible"
-	S Y=$P(DGMT0,"^") X ^DD("DD") W !,"Primary Means Test ",$S(DGCS=1:"Required from",1:"Last Applied")," '",Y,"'"
-	I ("^2^4^5^6^16^")[("^"_DGCS_"^") S Y=$P(DGMT0,"^",7) X ^DD("DD") W " (COMPLETED: ",Y,")"
-	I DGCS=3 S Y=$P(DGMT0,"^",17) X ^DD("DD") W " (NO LONGER REQUIRED: ",Y,")"
-DISQ	Q
-	;
-EDT(DFN,DGDT)	;Display patients current MT information and provide
-	;        the user with the option of proceeding with a required
-	;        MT or editing an existing means test
-	;         Input  -- DFN    Patient IEN
-	;                   DGDT   Date/Time
-	;         Output -- None
-	;
-	; obtain lock used to synchronize local MT/CT options with income test upload
-	I $$LOCK^DGMTUTL(DFN)
-	;
-	D DIS(DFN)
-	S DGMTI=+$$LST(DFN,DGDT) G EDTQ:'DGMTI!(DGMTI'=+$$LST^DGMTU(DFN))
-	S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTDT=+DGMT0,DGMTS=$P(DGMT0,"^",3)
-	S DIR("A")="Do you wish to "_$S(DGMTS=1:"proceed with",1:"edit")_" the means test at this time"
-	S DIR("B")=$S(DGMTS&($D(DGPRFLG)):"NO",DGMTS=1:"YES",1:"NO"),DIR(0)="Y"
-	W ! D ^DIR G EDTQ:$D(DTOUT)!($D(DUOUT))
-	I Y S DGMTYPT=1,DGMTACT="EDT",DGMTROU="EDTQ^DGMTU" G EN^DGMTSC
-EDTQ	K DGMT0,DGMTACT,DGMTDT,DGMTI,DGMTROU,DGMTS,DIR,DTOUT,DUOUT,Y
-	;
-	; release lock
-	D UNLOCK^DGMTUTL(DFN)
-	;
-	Q
-	;
-CMTS(DFN)	;Get Current MT Status - query HEC if necessary
-	;
-	;        Input: DFN=patient ien
-	;       Output: MT IEN^Date of Test^Status Name
-	;                 ^Status Code^Source of Test
-	;
-	N X,Y,DGMTDATA,DGQSENT,DGDOD,NODE0,DGRET,DGMFLG,DGTAG,DGMTYPT
-	D CHKPT^DGMTU4(DFN)
-	S DGMTYPT=1,DGMTDATA=$$LST(DFN,"",DGMTYPT)
-	;Next line checks to see if patient has expired, if so, Query not initiated
-	S DGDOD=$P($G(^DPT(DFN,.35)),U)
-	I +DGDOD Q DGMTDATA
-	;Next line checks to see if current test exists, if not, Query not initiated 
-	I '$G(DGMTDATA) Q DGMTDATA
-	D:+$$QFLG(DGMTDATA)
-	.I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN),$G(DGMFLG)'=0 D
-	..I $$LOCK^DGMTUTL(DFN)
-	..D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1
-	..I '$D(ZTQUEUED),'$G(DGMSGF),$G(DGQSENT) W !!,"Financial query queued to be sent to HEC...",! H .5
-	..D UNLOCK^DGMTUTL(DFN)
-	.S DGMTDATA=$$LST(DFN,"",DGMTYPT)
-	D:+$$MFLG(DGMTDATA)
-	.S DGMFLG=$$MFLG(DGMTDATA)
-	.S DGTAG=$S(DGMFLG=1:"MSG"_DGMFLG,DGMFLG=2:"MSG"_DGMFLG,1:0)
-	.I DGTAG["MSG",'$G(DGMSGF) D @DGTAG
-	Q DGMTDATA   ;return most current MT data
-MFLG(DGMTDATA)	;Set up appropriate informational message flag for user's
-	;benefit.
-	;Input        -     DGMTDATA as defined by $$LST function.
-	;Output       -     DGRETV
-	;     1 = Current Test is REQUIRED
-	;     2 = Test is > 365 days old and is in a status of
-	;         other than REQUIRED or NO LONGER REQUIRED
-	;     2 = Pend Adj for GMT, test date is 10/6/99 or
-	;         greater and agreed to the deductible
-	;     0 = CAT C/Pend Adj for MT, test date is 10/6/99
-	;         or greater and agreed to the deductible.
-	; OR  0 = Cat C, declined income info and agreed
-	;         to pay deductible.
-	; OR  0 = Has a future dated Means Test
-	N DGRETV,FTST,DGMT0
-	S DGRETV=0 I '$G(DGMTDATA) Q DGRETV
-	S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
-	I $P(DGMTDATA,U,4)="R" S DGRETV=1
-	I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S DGRETV=2
-	I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S DGRETV=0
-	I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
-	D DOM^DGMTR I $G(DGDOM) S DGRETV=0
-	S FTST=$$FUT(DFN)
-	I DGRETV,FTST,$P(^DGMT(408.31,+FTST,0),U,19)=1 S DGRETV=0
-	Q DGRETV
-MSG1	;Informational message 1
-	N NODE0,Y
-	S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
-	W !!,$C(7),?15,"*** Patient Requires a Means Test ***",!
-	S Y=$P(NODE0,U) X ^DD("DD") W !,?14,"Primary Means Test Required from "_Y,!
-	I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
-	Q
-MSG2	;Informational message 2
-	N NODE0,Y
-	S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
-	W !!,$C(7),?17,"*** Patient Requires a Means Test ***",!
-	S Y=$P(NODE0,U) X ^DD("DD") W !,?10,"Patient's Test dated "_Y_" is "_$P(DGMTDATA,U,3)_"."_" The test"
-	W !,?10,"date is greater than 365 days old.  Please update."
-	I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
-	Q
-QFLG(DGMTDATA)	;
-	;INPUT - DGMTDATA
-	;OUTPUT- IVMQFLG 1 if query is necessary 0 if not
-	N IVMQFLG,DGMT0
-	S IVMQFLG=0 I '$G(DGMTDATA) Q IVMQFLG
-	S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
-	;Set flag to 1 if Means test is Required.
-	I $P(DGMTDATA,U,4)="R" S IVMQFLG=1
-	;Set flag to 1 if Means test older than 365 days and status is not
-	;NO LONGER REQUIRED and not REQUIRED.
-	I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S IVMQFLG=1
-	;If Cat C/Pend Adj for MT, older than 365 days, agreed to pay, test
-	;date > 10/5/99 reset flag to 0 - no query is necessary.
-	I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S IVMQFLG=0
-	;If patient is Cat C, declined to provide income but has agreed to
-	;pay deductible, no query necessary - reset flag to 0
-	I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
-	;If patient is on a DOM ward, don't initiate query
-	D DOM^DGMTR I $G(DGDOM) S IVMQFLG=0
-	Q IVMQFLG
-	;
-FUT(DFN,DGDT,DGMTYPT)	; Future MT for a patient
-	;DFN      Patient IEN
-	;DGDT     Date (Optional- default to today)
-	;DGMTYPT  Type of Test (Optional - default to MT)
-	;Return
-	;If a DCD test was performed it will be returned, else the
-	;current future dated test for the Income Year.
-	;MT IEN^Date of Test^Status Name^Status Code^Source
-	;
-	N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,LAST,TYPTST
-	S:'$D(DGMTYPT) DGMTYPT=1
-	;no future LTC eg 02/15/2005
-	I ($G(DGMTYPT)=4) Q ""
-	S TYPTST=$S(DGMTYPT=2:"AF",1:"AE")
-	S DGIDT=$S($G(DGDT)>0:DGDT,1:DT),DONE=0
-	S (ARR,LAST,Y)=""
-	S:$P(DGIDT,".",2) DGIDT=$P(DGIDT,".")
-	F  S DGIDT=$O(^IVM(301.5,TYPTST,DFN,DGIDT)) Q:'DGIDT!(DONE)  D
-	.S MTIEN=0
-	.F  S MTIEN=$O(^IVM(301.5,TYPTST,DFN,DGIDT,MTIEN)) Q:'MTIEN!(DONE)  D
-	..Q:'$D(^DGMT(408.31,MTIEN,0))
-	..S MTNOD=^DGMT(408.31,MTIEN,0),SRCE=$P(MTNOD,U,23)
-	..I SRCE'=1 S DONE=1,Y=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23) Q
-	..I 'DONE,'$D(ARR($P(MTNOD,U),MTIEN)) S ARR($P(MTNOD,U),MTIEN)=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23)
-	I 'DONE S LAST=$O(ARR(""),-1) I LAST S Y=ARR(LAST,$O(ARR(LAST,""),-1))
-	Q $G(Y)
+DGMTU ;ALB/RMO,LBD,BRM,EG - Means Test Utilities ; 02/08/2005 07:10 AM
+ ;;5.3;Registration;**4,33,182,277,290,374,358,420,426,411,332,433,456,476,519,451,630**;Aug 13, 1993
+ ;
+LST(DFN,DGDT,DGMTYPT) ;Last means test for a patient
+ ;         Input  -- DFN   Patient IEN
+ ;                   DGDT  Date/Time  (Optional- default today@2359)
+ ;                DGMTYPT  Type of Test (Optional - if not defined 
+ ;                                       Means Test will be assumed)
+ ;         Output -- Annual Means Test IEN^Date of Test
+ ;                   ^Status Name^Status Code^Source of Test
+ N DGIDT,DGMTFL1,DGMTI,DGNOD,Y I '$D(DGMTYPT) S DGMTYPT=1
+ S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
+ F  S DGIDT=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT)) Q:'DGIDT!$G(DGMTFL1)  D
+ .F DGMTI=0:0 S DGMTI=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT,DGMTI)) Q:'DGMTI!$G(DGMTFL1)  D
+ ..S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD,$G(^("PRIM"))!(DGMTYPT=4) S DGMTFL1=1,Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS(DFN,+$P(^(0),"^",3))_"^"_$P(DGNOD,"^",23) ; chk for primary MT
+ Q $G(Y)
+ ;
+LVMT(DFN,DGDT) ;Last valid means test (status other than required)
+ ;          Input  -- DFN    Patient IEN
+ ;                    DGDT   Date (Optional - default today)
+ ;          Output -- Annual Means Test IEN^Date of Test^Status Name
+ ;                     ^Status Code
+ N DGMT,DGMTL
+ S:'$D(DGDT) DGDT=DT S DGMTL=$$LST^DGMTU(DFN,DGDT)
+ I $P(DGMTL,"^",4)="R" F  S DGMT=$$LST^DGMTU(DFN,DGDT) Q:DGMT']""!($P(DGMT,U,4)'="R")  S DGDT=$P(DGMT,U,2)-1
+ Q $S($G(DGMT)]"":DGMT,1:$G(DGMTL))
+ ;
+NVMT(DFN,DGDT) ;Next valid means test (status other than required)
+ ;          Input  -- DFN    Patient IEN
+ ;                    DGDT   Date (Required)
+ ;          Output -- Annual Means Test IEN^Date of Test^Status Name
+ ;                     ^Status Code
+ N DGDTE,DGMT,DGMT0,DGMTI,DGMTPR,DGMTS
+ S DGDTE=DGDT
+ F  S DGDTE=$O(^DGMT(408.31,"AD",1,DFN,DGDTE)) Q:'DGDTE!$G(DGMT)  D
+ .F DGMTI=0:0 S DGMTI=$O(^DGMT(408.31,"AD",1,DFN,DGDTE,DGMTI)) Q:'DGMTI  S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTS=+$P(DGMT0,"^",3),DGMTPR=$G(^("PRIM")) I +DGMT0,DGMTS'=1,DGMTPR S DGMT=DGMTI_"^"_+DGMT0_"^"_$$MTS^DGMTU(DFN,DGMTS) Q
+ Q $G(DGMT)
+ ;
+MTS(DFN,DGMTS) ;Means test status -- default current
+ ;         Input  -- DFN    Patient IEN
+ ;                   DGMTS  Means Test Status IEN  (Optional)
+ ;         Output -- Status Name^Status Code
+ N Y
+ S DGMTS=$S($G(DGMTS)>0:DGMTS,1:$P($G(^DPT(DFN,0)),"^",14))
+ I DGMTS S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2)
+ Q $G(Y)
+ ;
+DIS(DFN) ;Display patients current means test status,
+ ;        eligibility for care, deductible information,
+ ;        date of test and date of completion
+ ;         Input  -- DFN    Patient IEN
+ ;         Output -- None
+ N DGCS,DGDED,DGMTI,DGMT0
+ S DGCS=$P($G(^DPT(DFN,0)),"^",14) G DISQ:DGCS=""
+ S DGMTI=+$$LST^DGMTU(DFN),DGMT0=$G(^DGMT(408.31,DGMTI,0))
+ S MTSIG=$P(DGMT0,"^",29)
+ W !,"Means Test Signed?: ",$S(MTSIG=1:"YES",MTSIG=0:"NO",MTSIG=9:"DELETED",1:"")
+ I DGCS=1 W !!,"Patient Requires a Means Test"
+ I DGCS=2 W !!,"Patient's Means Test is Pending Adjudication for "_$$PA^DGMTUTL(DGMTI)
+ I DGCS=3 W !!,"Means Test Not Required"
+ I ("^4^5^6^16^")[("^"_DGCS_"^") W !!,"Patient's status is ",$$GETNAME^DGMTH(DGCS)," based on primary means test"
+ I $D(^DG(408.32,DGCS,"MSG")) W !,^("MSG")
+ I DGCS=6 S DGDED=$P(DGMT0,"^",11) W ! W:DGDED]"" "Has",$S(DGDED:"",1:" not")," agreed to pay the deductible"
+ S Y=$P(DGMT0,"^") X ^DD("DD") W !,"Primary Means Test ",$S(DGCS=1:"Required from",1:"Last Applied")," '",Y,"'"
+ I ("^2^4^5^6^16^")[("^"_DGCS_"^") S Y=$P(DGMT0,"^",7) X ^DD("DD") W " (COMPLETED: ",Y,")"
+ I DGCS=3 S Y=$P(DGMT0,"^",17) X ^DD("DD") W " (NO LONGER REQUIRED: ",Y,")"
+DISQ Q
+ ;
+EDT(DFN,DGDT) ;Display patients current means test information and provide
+ ;        the user with the option of proceeding with a required
+ ;        means test or editing an existing means test
+ ;         Input  -- DFN    Patient IEN
+ ;                   DGDT   Date/Time
+ ;         Output -- None
+ ;
+ ; obtain lock used to synchronize local MT/CT options with income test upload
+ I $$LOCK^DGMTUTL(DFN)
+ ;
+ D DIS(DFN)
+ S DGMTI=+$$LST(DFN,DGDT) G EDTQ:'DGMTI!(DGMTI'=+$$LST^DGMTU(DFN))
+ S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGMTDT=+DGMT0,DGMTS=$P(DGMT0,"^",3)
+ S DIR("A")="Do you wish to "_$S(DGMTS=1:"proceed with",1:"edit")_" the means test at this time"
+ S DIR("B")=$S(DGMTS=1:"YES",1:"NO"),DIR(0)="Y"
+ W ! D ^DIR G EDTQ:$D(DTOUT)!($D(DUOUT))
+ I Y S DGMTYPT=1,DGMTACT="EDT",DGMTROU="EDTQ^DGMTU" G EN^DGMTSC
+EDTQ K DGMT0,DGMTACT,DGMTDT,DGMTI,DGMTROU,DGMTS,DIR,DTOUT,DUOUT,Y
+ ;
+ ; release lock
+ D UNLOCK^DGMTUTL(DFN)
+ ;
+ Q
+ ;
+CMTS(DFN) ;Get Current Means Test Status - query HEC if necessary
+ ;
+ ;        Input: DFN=patient ien
+ ;       Output: MT IEN^Date of Test^Status Name
+ ;                 ^Status Code^Source of Test
+ ;
+ N X,Y,DGMTDATA,DGQSENT,DGDOD,NODE0,DGRET,DGMFLG,DGTAG,DGMTYPT
+ D CHKPT^DGMTU4(DFN)
+ S DGMTYPT=1,DGMTDATA=$$LST(DFN,"",DGMTYPT)
+ ;Next line checks to see if patient has expired, if so, Query not initiated
+ S DGDOD=$P($G(^DPT(DFN,.35)),U)
+ I +DGDOD Q DGMTDATA
+ ;Next line checks to see if current test exists, if not, Query not initiated 
+ I '$G(DGMTDATA) Q DGMTDATA
+ D:+$$QFLG(DGMTDATA)
+ .I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN),$G(DGMFLG)'=0 D
+ ..I $$LOCK^DGMTUTL(DFN)
+ ..D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1
+ ..I '$D(ZTQUEUED),'$G(DGMSGF),$G(DGQSENT) W !!,"Financial query queued to be sent to HEC...",! H .5
+ ..D UNLOCK^DGMTUTL(DFN)
+ .S DGMTDATA=$$LST(DFN,"",DGMTYPT)
+ D:+$$MFLG(DGMTDATA)
+ .S DGMFLG=$$MFLG(DGMTDATA)
+ .S DGTAG=$S(DGMFLG=1:"MSG"_DGMFLG,DGMFLG=2:"MSG"_DGMFLG,1:0)
+ .I DGTAG["MSG",'$G(DGMSGF) D @DGTAG
+ Q DGMTDATA   ;return most current MT data
+MFLG(DGMTDATA) ;Set up appropriate informational message flag for user's
+ ;benefit.
+ ;Input        -     DGMTDATA as defined by $$LST function.
+ ;Output       -     DGRETV
+ ;     1 = Current Test is REQUIRED
+ ;     2 = Test is > 365 days old and is in a status of
+ ;         other than REQUIRED or NO LONGER REQUIRED
+ ;     2 = Pend Adj for GMT, test date is 10/6/99 or
+ ;         greater and agreed to the deductible
+ ;     0 = CAT C/Pend Adj for MT, test date is 10/6/99
+ ;         or greater and agreed to the deductible.
+ ; OR  0 = Cat C, declined income info and agreed
+ ;         to pay deductible.
+ ; OR  0 = Has a future dated Means Test
+ N DGRETV,FTST,DGMT0
+ S DGRETV=0 I '$G(DGMTDATA) Q DGRETV
+ S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
+ I $P(DGMTDATA,U,4)="R" S DGRETV=1
+ I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S DGRETV=2
+ I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S DGRETV=0
+ I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
+ D DOM^DGMTR I $G(DGDOM) S DGRETV=0
+ S FTST=$$FUT(DFN)
+ I DGRETV,FTST,$P(^DGMT(408.31,+FTST,0),U,19)=1 S DGRETV=0
+ Q DGRETV
+MSG1 ;Informational message 1
+ N NODE0,Y
+ S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
+ W !!,$C(7),?15,"*** Patient Requires a Means Test ***",!
+ S Y=$P(NODE0,U) X ^DD("DD") W !,?14,"Primary Means Test Required from "_Y,!
+ I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
+ Q
+MSG2 ;Informational message 2
+ N NODE0,Y
+ S NODE0=$G(^DGMT(408.31,+DGMTDATA,0))
+ W !!,$C(7),?17,"*** Patient Requires a Means Test ***",!
+ S Y=$P(NODE0,U) X ^DD("DD") W !,?10,"Patient's Test dated "_Y_" is "_$P(DGMTDATA,U,3)_"."_" The test"
+ W !,?10,"date is greater than 365 days old.  Please update."
+ I $G(IOST)["C-" R !!,"Enter <RETURN> to continue.",DGRET:DTIME
+ Q
+QFLG(DGMTDATA) ;
+ ;INPUT - DGMTDATA
+ ;OUTPUT- IVMQFLG 1 if query is necessary 0 if not
+ N IVMQFLG,DGMT0
+ S IVMQFLG=0 I '$G(DGMTDATA) Q IVMQFLG
+ S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0))
+ ;Set flag to 1 if Means test is Required.
+ I $P(DGMTDATA,U,4)="R" S IVMQFLG=1
+ ;Set flag to 1 if Means test older than 365 days and status is not
+ ;NO LONGER REQUIRED and not REQUIRED.
+ I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S IVMQFLG=1
+ ;If Cat C/Pend Adj for MT, older than 365 days, agreed to pay, test
+ ;date > 10/5/99 reset flag to 0 - no query is necessary.
+ I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S IVMQFLG=0
+ ;If patient is Cat C, declined to provide income but has agreed to
+ ;pay deductible, no query necessary - reset flag to 0
+ I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0
+ ;If patient is on a DOM ward, don't initiate query
+ D DOM^DGMTR I $G(DGDOM) S IVMQFLG=0
+ Q IVMQFLG
+ ;
+FUT(DFN,DGDT,DGMTYPT) ; Future Means Tests for a patient
+ ;DFN      Patient IEN
+ ;DGDT     Date (Optional- default to today)
+ ;DGMTYPT  Type of Test (Optional - default to MT)
+ ;Return
+ ;If a DCD test was performed it will be returned, else the
+ ;current future dated test for the Income Year.
+ ;MT IEN^Date of Test^Status Name^Status Code^Source
+ ;
+ N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,LAST,TYPTST
+ S:'$D(DGMTYPT) DGMTYPT=1
+ ;no future LTC eg 02/15/2005
+ I ($G(DGMTYPT)=4) Q ""
+ S TYPTST=$S(DGMTYPT=2:"AF",1:"AE")
+ S DGIDT=$S($G(DGDT)>0:DGDT,1:DT),DONE=0
+ S (ARR,LAST,Y)=""
+ S:$P(DGIDT,".",2) DGIDT=$P(DGIDT,".")
+ F  S DGIDT=$O(^IVM(301.5,TYPTST,DFN,DGIDT)) Q:'DGIDT!(DONE)  D
+ .S MTIEN=0
+ .F  S MTIEN=$O(^IVM(301.5,TYPTST,DFN,DGIDT,MTIEN)) Q:'MTIEN!(DONE)  D
+ ..Q:'$D(^DGMT(408.31,MTIEN,0))
+ ..S MTNOD=^DGMT(408.31,MTIEN,0),SRCE=$P(MTNOD,U,23)
+ ..I SRCE'=1 S DONE=1,Y=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23) Q
+ ..I 'DONE,'$D(ARR($P(MTNOD,U),MTIEN)) S ARR($P(MTNOD,U),MTIEN)=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23)
+ I 'DONE S LAST=$O(ARR(""),-1) I LAST S Y=ARR(LAST,$O(ARR(LAST,""),-1))
+ Q $G(Y)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m	(revision 623)
@@ -1,295 +1,295 @@
-DGPFUT	;ALB/RPM - PRF UTILITIES ;7:46 PM  30 Jan 2008
-	;;5.3;Registration;**425,554,650,VWEHR1**;WorldVistA 30-Jan-08;Build 4
-	;
-	;Modified from FOIA VISTA,
-	;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
-	;General Public License See attached copy of the License.
-	;
-	;This program is free software; you can redistribute it and/or modify
-	;it under the terms of the GNU General Public License as published by
-	;the Free Software Foundation; either version 2 of the License, or
-	;(at your option) any later version.
-	;
-	;This program is distributed in the hope that it will be useful,
-	;but WITHOUT ANY WARRANTY; without even the implied warranty of
-	;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	;GNU General Public License for more details.
-	;
-	;You should have received a copy of the GNU General Public License along
-	;with this program; if not, write to the Free Software Foundation, Inc.,
-	;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-	;
-	Q   ;no direct entry
-	;
-ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS)	;wrap FileMan Classic Reader call
-	;
-	;  Input
-	;    DGDIR0 - DIR(0) string
-	;    DGDIRA - DIR("A") string
-	;    DGDIRB - DIR("B") string
-	;    DGDIRH - DIR("?") string
-	;    DGDIRS - DIR("S") string
-	;
-	;  Output
-	;   Function Value - Internal value returned from ^DIR or -1 if user
-	;                    up-arrows, double up-arrows or the read times out.
-	;
-	;          DIR(0) type      Results
-	;          ------------     -------------------------------
-	;          DD               IEN of selected entry
-	;          Pointer          IEN of selected entry
-	;          Set of Codes     Internal value of code
-	;          Yes/No           0 for No, 1 for Yes
-	;
-	N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y  ;^DIR variables
-	;
-	S DIR(0)=DGDIR0
-	S DIR("A")=$G(DGDIRA)
-	I $G(DGDIRB)]"" S DIR("B")=DGDIRB
-	I $D(DGDIRH) S DIR("?")=DGDIRH
-	I $G(DGDIRS)]"" S DIR("S")=DGDIRS
-	D ^DIR
-	Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,X="@":"@",1:$P(Y,U))
-	;
-CONTINUE()	;pause display
-	;
-	;  Input:  none
-	;
-	;  Output:  1 - continue
-	;           0 - quit
-	;
-	N DIR,Y
-	S DIR(0)="E" D ^DIR
-	Q $S(Y'=1:0,1:1)
-	;
-VALID(DGRTN,DGFILE,DGIP,DGERR)	;validate input values before filing
-	;
-	;  Input:
-	;    DGRTN - (required) Routine name that contains $TEXT table
-	;   DGFILE - (required) File number for input values
-	;     DGIP - (required) Input value array
-	;    DGERR - (optional) Returns error message passed by reference
-	;
-	;  Output:
-	;   Function Value - Returns 1 on all values valid, 0 on failure
-	;
-	I $G(DGRTN)=""!('$G(DGFILE)) Q 0
-	N DGVLD   ;function return value
-	N DGFXR   ;node name to field xref array
-	N DGREQ   ;array of required fields
-	N DGWP    ;word processing flag
-	N DGN     ;array node name
-	;
-	S DGVLD=1
-	S DGN=""
-	D BLDXR(DGRTN,.DGFXR)
-	;
-	F  S DGN=$O(DGFXR(DGN)) Q:DGN=""  D  Q:'DGVLD
-	. S DGREQ=$P(DGFXR(DGN),U,2)
-	. S DGWP=$P(DGFXR(DGN),U,3)
-	. I DGREQ D   ;required field check
-	. . I DGWP,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
-	. . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0 Q
-	. I 'DGVLD D  Q
-	. . S DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
-	. Q:DGWP  ;don't check word processing fields for invalid values
-	. ;check for invalid values
-	. I '$$TESTVAL(DGFILE,+DGFXR(DGN),$P($G(DGIP(DGN)),U)) D  Q
-	. . S DGVLD=0,DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID"
-	Q DGVLD
-	;
-BLDXR(DGRTN,DGFLDA)	;build name/field xref array
-	;This procedure reads in the text from the XREF line tag of the DGRTN
-	;input parameter and loads name/field xref array with parsed line data.
-	;
-	;  Input:
-	;    DGRTN - (required) Routine name that contains the XREF line tag
-	;   DGFLDA - (required) Array name for name/field xref passed by
-	;            reference
-	;
-	;  Output:
-	;   Function Value - Returns 1 on success, 0 on failure
-	;           DGFLDA - Name/field xref array
-	;                  format: DGFLDA(subscript)=field#^required?^word proc?
-	;
-	S DGRTN=$G(DGRTN)
-	Q:DGRTN=""
-	I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
-	Q:($T(@DGRTN)="")
-	N DGTAG
-	N DGOFF
-	N DGLINE
-	;
-	F DGOFF=1:1 S DGTAG="XREF+"_DGOFF_DGRTN,DGLINE=$T(@DGTAG) Q:DGLINE=""  D
-	. S DGFLDA($P(DGLINE,";",3))=$P(DGLINE,";",4)_U_+$P(DGLINE,";",5)_U_+$P(DGLINE,";",6)
-	Q
-	;
-CKWP(DGROOT)	;ck word processing required fields
-	;This function verifies that at least one line in the word processing
-	;array contains text more than one space long.
-	;
-	;  Input:
-	;    DGROOT - (required) Word processing root
-	;
-	;  Output:
-	;   Function Value - Returns 1 on success, 0 on failure
-	;
-	N DGLIN
-	N DGRSLT
-	S DGRSLT=0
-	I $D(@DGROOT) D
-	. S DGLIN=""
-	. F  S DGLIN=$O(@DGROOT@(DGLIN)) Q:DGLIN=""  D  Q:DGRSLT
-	. . I $G(@DGROOT@(DGLIN,0))]"",@DGROOT@(DGLIN,0)'=" " S DGRSLT=1
-	Q DGRSLT
-	;
-TESTVAL(DGFIL,DGFLD,DGVAL)	;validate individual value against field def
-	;
-	;  Input:
-	;    DGFIL - (required) File number
-	;    DGFLD - (required) Field number
-	;    DGVAL - (required) Field value to be validated
-	;
-	;  Output:
-	;   Function Value - Returns 1 if value is valid, 0 if value is invalid
-	;
-	N DGVALEX  ;external value after conversion
-	N DGTYP    ;field type
-	N DGRSLT   ;results of CHK^DIE
-	N VALID    ;function results
-	;
-	S VALID=1
-	I $G(DGFIL)>0,($G(DGFLD)>0),($G(DGVAL)'="") D
-	. S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
-	. I DGVALEX="" S VALID=0 Q
-	. I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER" D
-	. . D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 Q
-	Q VALID
-	;
-STATUS(DGACT)	;calculate the assignment STATUS given an ACTION code
-	;
-	;  Input:
-	;    DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
-	;            HISTORY (#26.14) file in internal or external format
-	;
-	;  Output:
-	;   Function Value - Status value on success, -1 on failure
-	;
-	N DGERR   ;FM message root
-	N DGRSLT  ;CHK^DIE result array
-	N DGSTAT  ;calculated status value
-	;
-	S DGSTAT=-1
-	I $G(DGACT)]"" D
-	. I DGACT?1.N S DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
-	. Q:$D(DGERR)
-	. D CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
-	. Q:$D(DGERR)
-	. I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
-	. E  S DGSTAT=1
-	Q DGSTAT
-	;
-MPIOK(DGDFN,DGICN)	;return national ICN
-	;This function verifies that a given patient has a valid national
-	;Integration Control Number.
-	;
-	;  Supported DBIA #2701:  The supported DBIA is used to access MPI
-	;                         APIs to retrieve ICN and determine if ICN
-	;                         is local.
-	;
-	;  Input:
-	;    DGDFN - (required) IEN of patient in PATIENT (#2) file
-	;    DGICN - (optional) passed by reference to contain national ICN
-	;
-	;  Output:
-	;   Function Value - 1 on valid national ICN;
-	;                    0 on failure
-	;            DGICN - Patient's Integrated Control Number
-	;
-	N DGRSLT
-	S DGRSLT=0
-	I $G(DGDFN)>0 D
-	. S DGICN=$$GETICN^MPIF001(DGDFN)
-	. ;
-	. ;ICN must be valid
-	. Q:(DGICN'>0)
-	. ;
-	. ;ICN must not be local
-	. Q:$$IFLOCAL^MPIF001(DGDFN)
-	. ;
-	. S DGRSLT=1
-	Q DGRSLT
-	;
-GETNXTF(DGDFN,DGLTF)	;get previous treating facility
-	;This function will return the treating facility with a DATE LAST
-	;TREATED value immediately prior to the date for the treating facility
-	;passed as the second parameter.  The most recent treating facility
-	;will be returned when the second parameter is missing, null, or zero.
-	;
-	;  Input:
-	;    DGDFN - pointer to patient in PATIENT (#2) file
-	;    DGLTF - (optional) last treating facility [default=0]
-	;
-	;  Output:
-	;    Function value - previous facility as a pointer to INSTITUTION (#4)
-	;                     file on success; 0 on failure
-	;
-	N DGARR   ;fully subscripted array node
-	N DGDARR  ;date sorted treating facilities
-	N DGINST  ;institution pointer
-	N DGNAM   ;name of sorted treating facilities array
-	N DGTFARR  ;array of non-local treating facilities
-	;
-	;
-	I $G(DGDFN)>0,$$BLDTFL^DGPFUT2(DGDFN,.DGTFARR) D
-	. ;
-	. ;validate last treating facility input parameter
-	. S DGLTF=+$G(DGLTF)
-	. S DGLTF=$S(DGLTF&($D(DGTFARR(DGLTF))):DGLTF,1:0)
-	. ;
-	. ;build date sorted list
-	. S DGINST=0
-	. F  S DGINST=$O(DGTFARR(DGINST)) Q:'DGINST  D
-	. . S DGDARR(DGTFARR(DGINST),DGINST)=""
-	. ;
-	. ;find entry for previous treating facility
-	. S DGNAM="DGDARR"
-	. ;
-	. ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
-	. ;
-	. ;S DGARR=$QUERY(@DGNAM@(""),-1)
-	. S DGARR=$$Q^VWUTIL($NA(@DGNAM@("")),-1)
-	. ;
-	. ;END CHANGE
-	. ;
-	. I DGLTF,DGARR]"" D
-	. . I $QS(DGARR,2)'=DGLTF D
-	. . . ;
-	. . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
-	. . . ;
-	. . . ;F  S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
-	. . . F  S DGARR=$$Q^VWUTIL($NA(@DGARR),-1) Q:+$QS(DGARR,2)=DGLTF
-	. . . ;
-	. . . ;END CHANGE
-	. . . ;
-	. . ;
-	. . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
-	. . ;
-	. . ;S DGARR=$QUERY(@DGARR,-1)
-	. . S DGARR=$$Q^VWUTIL($NA(@DGARR),-1)
-	. . ;
-	. . ;END CHANGE
-	. . ;
-	;
-	Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)
-	;
-ISDIV(DGSITE)	;is site local division
-	;
-	;  Input:
-	;    DGSITE - pointer to INSTITUTION (#4) file
-	;
-	;  Output:
-	;    Function value - 1 on success; 0 on failure
-	;
-	S DGSITE=+$G(DGSITE)
-	Q $S($D(^DG(40.8,"AD",DGSITE)):1,1:0)
+DGPFUT ;ALB/RPM - PRF UTILITIES ;7:46 PM  30 Jan 2008
+ ;;5.3;Registration;**425,554,650,VWEHR1**;WorldVistA 30-Jan-08
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ Q   ;no direct entry
+ ;
+ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
+ ;
+ ;  Input
+ ;    DGDIR0 - DIR(0) string
+ ;    DGDIRA - DIR("A") string
+ ;    DGDIRB - DIR("B") string
+ ;    DGDIRH - DIR("?") string
+ ;    DGDIRS - DIR("S") string
+ ;
+ ;  Output
+ ;   Function Value - Internal value returned from ^DIR or -1 if user
+ ;                    up-arrows, double up-arrows or the read times out.
+ ;
+ ;          DIR(0) type      Results
+ ;          ------------     -------------------------------
+ ;          DD               IEN of selected entry
+ ;          Pointer          IEN of selected entry
+ ;          Set of Codes     Internal value of code
+ ;          Yes/No           0 for No, 1 for Yes
+ ;
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y  ;^DIR variables
+ ;
+ S DIR(0)=DGDIR0
+ S DIR("A")=$G(DGDIRA)
+ I $G(DGDIRB)]"" S DIR("B")=DGDIRB
+ I $D(DGDIRH) S DIR("?")=DGDIRH
+ I $G(DGDIRS)]"" S DIR("S")=DGDIRS
+ D ^DIR
+ Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,X="@":"@",1:$P(Y,U))
+ ;
+CONTINUE() ;pause display
+ ;
+ ;  Input:  none
+ ;
+ ;  Output:  1 - continue
+ ;           0 - quit
+ ;
+ N DIR,Y
+ S DIR(0)="E" D ^DIR
+ Q $S(Y'=1:0,1:1)
+ ;
+VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing
+ ;
+ ;  Input:
+ ;    DGRTN - (required) Routine name that contains $TEXT table
+ ;   DGFILE - (required) File number for input values
+ ;     DGIP - (required) Input value array
+ ;    DGERR - (optional) Returns error message passed by reference
+ ;
+ ;  Output:
+ ;   Function Value - Returns 1 on all values valid, 0 on failure
+ ;
+ I $G(DGRTN)=""!('$G(DGFILE)) Q 0
+ N DGVLD   ;function return value
+ N DGFXR   ;node name to field xref array
+ N DGREQ   ;array of required fields
+ N DGWP    ;word processing flag
+ N DGN     ;array node name
+ ;
+ S DGVLD=1
+ S DGN=""
+ D BLDXR(DGRTN,.DGFXR)
+ ;
+ F  S DGN=$O(DGFXR(DGN)) Q:DGN=""  D  Q:'DGVLD
+ . S DGREQ=$P(DGFXR(DGN),U,2)
+ . S DGWP=$P(DGFXR(DGN),U,3)
+ . I DGREQ D   ;required field check
+ . . I DGWP,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
+ . . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0 Q
+ . I 'DGVLD D  Q
+ . . S DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
+ . Q:DGWP  ;don't check word processing fields for invalid values
+ . ;check for invalid values
+ . I '$$TESTVAL(DGFILE,+DGFXR(DGN),$P($G(DGIP(DGN)),U)) D  Q
+ . . S DGVLD=0,DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID"
+ Q DGVLD
+ ;
+BLDXR(DGRTN,DGFLDA) ;build name/field xref array
+ ;This procedure reads in the text from the XREF line tag of the DGRTN
+ ;input parameter and loads name/field xref array with parsed line data.
+ ;
+ ;  Input:
+ ;    DGRTN - (required) Routine name that contains the XREF line tag
+ ;   DGFLDA - (required) Array name for name/field xref passed by
+ ;            reference
+ ;
+ ;  Output:
+ ;   Function Value - Returns 1 on success, 0 on failure
+ ;           DGFLDA - Name/field xref array
+ ;                  format: DGFLDA(subscript)=field#^required?^word proc?
+ ;
+ S DGRTN=$G(DGRTN)
+ Q:DGRTN=""
+ I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
+ Q:($T(@DGRTN)="")
+ N DGTAG
+ N DGOFF
+ N DGLINE
+ ;
+ F DGOFF=1:1 S DGTAG="XREF+"_DGOFF_DGRTN,DGLINE=$T(@DGTAG) Q:DGLINE=""  D
+ . S DGFLDA($P(DGLINE,";",3))=$P(DGLINE,";",4)_U_+$P(DGLINE,";",5)_U_+$P(DGLINE,";",6)
+ Q
+ ;
+CKWP(DGROOT) ;ck word processing required fields
+ ;This function verifies that at least one line in the word processing
+ ;array contains text more than one space long.
+ ;
+ ;  Input:
+ ;    DGROOT - (required) Word processing root
+ ;
+ ;  Output:
+ ;   Function Value - Returns 1 on success, 0 on failure
+ ;
+ N DGLIN
+ N DGRSLT
+ S DGRSLT=0
+ I $D(@DGROOT) D
+ . S DGLIN=""
+ . F  S DGLIN=$O(@DGROOT@(DGLIN)) Q:DGLIN=""  D  Q:DGRSLT
+ . . I $G(@DGROOT@(DGLIN,0))]"",@DGROOT@(DGLIN,0)'=" " S DGRSLT=1
+ Q DGRSLT
+ ;
+TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
+ ;
+ ;  Input:
+ ;    DGFIL - (required) File number
+ ;    DGFLD - (required) Field number
+ ;    DGVAL - (required) Field value to be validated
+ ;
+ ;  Output:
+ ;   Function Value - Returns 1 if value is valid, 0 if value is invalid
+ ;
+ N DGVALEX  ;external value after conversion
+ N DGTYP    ;field type
+ N DGRSLT   ;results of CHK^DIE
+ N VALID    ;function results
+ ;
+ S VALID=1
+ I $G(DGFIL)>0,($G(DGFLD)>0),($G(DGVAL)'="") D
+ . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
+ . I DGVALEX="" S VALID=0 Q
+ . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER" D
+ . . D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 Q
+ Q VALID
+ ;
+STATUS(DGACT) ;calculate the assignment STATUS given an ACTION code
+ ;
+ ;  Input:
+ ;    DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
+ ;            HISTORY (#26.14) file in internal or external format
+ ;
+ ;  Output:
+ ;   Function Value - Status value on success, -1 on failure
+ ;
+ N DGERR   ;FM message root
+ N DGRSLT  ;CHK^DIE result array
+ N DGSTAT  ;calculated status value
+ ;
+ S DGSTAT=-1
+ I $G(DGACT)]"" D
+ . I DGACT?1.N S DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
+ . Q:$D(DGERR)
+ . D CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
+ . Q:$D(DGERR)
+ . I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
+ . E  S DGSTAT=1
+ Q DGSTAT
+ ;
+MPIOK(DGDFN,DGICN) ;return national ICN
+ ;This function verifies that a given patient has a valid national
+ ;Integration Control Number.
+ ;
+ ;  Supported DBIA #2701:  The supported DBIA is used to access MPI
+ ;                         APIs to retrieve ICN and determine if ICN
+ ;                         is local.
+ ;
+ ;  Input:
+ ;    DGDFN - (required) IEN of patient in PATIENT (#2) file
+ ;    DGICN - (optional) passed by reference to contain national ICN
+ ;
+ ;  Output:
+ ;   Function Value - 1 on valid national ICN;
+ ;                    0 on failure
+ ;            DGICN - Patient's Integrated Control Number
+ ;
+ N DGRSLT
+ S DGRSLT=0
+ I $G(DGDFN)>0 D
+ . S DGICN=$$GETICN^MPIF001(DGDFN)
+ . ;
+ . ;ICN must be valid
+ . Q:(DGICN'>0)
+ . ;
+ . ;ICN must not be local
+ . Q:$$IFLOCAL^MPIF001(DGDFN)
+ . ;
+ . S DGRSLT=1
+ Q DGRSLT
+ ;
+GETNXTF(DGDFN,DGLTF) ;get previous treating facility
+ ;This function will return the treating facility with a DATE LAST
+ ;TREATED value immediately prior to the date for the treating facility
+ ;passed as the second parameter.  The most recent treating facility
+ ;will be returned when the second parameter is missing, null, or zero.
+ ;
+ ;  Input:
+ ;    DGDFN - pointer to patient in PATIENT (#2) file
+ ;    DGLTF - (optional) last treating facility [default=0]
+ ;
+ ;  Output:
+ ;    Function value - previous facility as a pointer to INSTITUTION (#4)
+ ;                     file on success; 0 on failure
+ ;
+ N DGARR   ;fully subscripted array node
+ N DGDARR  ;date sorted treating facilities
+ N DGINST  ;institution pointer
+ N DGNAM   ;name of sorted treating facilities array
+ N DGTFARR  ;array of non-local treating facilities
+ ;
+ ;
+ I $G(DGDFN)>0,$$BLDTFL^DGPFUT2(DGDFN,.DGTFARR) D
+ . ;
+ . ;validate last treating facility input parameter
+ . S DGLTF=+$G(DGLTF)
+ . S DGLTF=$S(DGLTF&($D(DGTFARR(DGLTF))):DGLTF,1:0)
+ . ;
+ . ;build date sorted list
+ . S DGINST=0
+ . F  S DGINST=$O(DGTFARR(DGINST)) Q:'DGINST  D
+ . . S DGDARR(DGTFARR(DGINST),DGINST)=""
+ . ;
+ . ;find entry for previous treating facility
+ . S DGNAM="DGDARR"
+ . ;
+ . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ . ;
+ . ;S DGARR=$QUERY(@DGNAM@(""),-1)
+ . S DGARR=$$Q^VWUTIL($NA(@DGNAM@("")),-1)
+ . ;
+ . ;END CHANGE
+ . ;
+ . I DGLTF,DGARR]"" D
+ . . I $QS(DGARR,2)'=DGLTF D
+ . . . ;
+ . . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ . . . ;
+ . . . ;F  S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
+ . . . F  S DGARR=$$Q^VWUTIL($NA(@DGARR),-1) Q:+$QS(DGARR,2)=DGLTF
+ . . . ;
+ . . . ;END CHANGE
+ . . . ;
+ . . ;
+ . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ . . ;
+ . . ;S DGARR=$QUERY(@DGARR,-1)
+ . . S DGARR=$$Q^VWUTIL($NA(@DGARR),-1)
+ . . ;
+ . . ;END CHANGE
+ . . ;
+ ;
+ Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)
+ ;
+ISDIV(DGSITE) ;is site local division
+ ;
+ ;  Input:
+ ;    DGSITE - pointer to INSTITUTION (#4) file
+ ;
+ ;  Output:
+ ;    Function value - 1 on success; 0 on failure
+ ;
+ S DGSITE=+$G(DGSITE)
+ Q $S($D(^DG(40.8,"AD",DGSITE)):1,1:0)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTF4.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTF4.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTF4.m	(revision 623)
@@ -1,88 +1,86 @@
-DGPTF4	;ALB/JDS - PTF ENTRY/EDIT-4 ; 2/19/04 9:33am
-	;;5.3;Registration;**114,115,397,510,517,478,683,775**;Aug 13, 1993;Build 3
-	;
-WR	;
-	W @IOF,HEAD,?72 S Z="<701>" D Z^DGPTFM K X S $P(X,"-",81)="" W !,X
-	Q
-EN	S Y=+B(70) D D^DGPTUTL W ! S Z=5 D Z W $S($P(B(0),U,11)=1:"Date of Disch: ",1:"Census Date  : ") S Z=Y,Z1=20 D Z1 W "Disch Specialty: ",$S($D(^DIC(42.4,+$P(B(70),U,2),0)):$E($P(^(0),U,1),1,25),1:"")
-	W !,"   Type of Disch: " S L=";"_$P(^DD(45,72,0),U,3),L1=";"_$P(B(70),U,3)_":" W $P($P(L,L1,2),";",1),?41 S L=";"_$P(^DD(45,72.1,0),U,3),L1=";"_$P(B(70),U,14)_":" W "Disch Status: ",$P($P(L,L1,2),";",1)
-	W !,"   Place of Disp: ",$S($D(^DIC(45.6,+$P(B(70),U,6),0)):$E($P(^(0),U,1),1,21),1:"")
-	W ?40 S Z=6 D Z W " Out Treat: ",$P("YES^^NO",U,+$P(B(70),U,4))
-	W !?6,"Means Test: " S L=";"_$P(^DD(45,10,0),U,3),L1=";"_$P(B(0),U,10)_":" W $P($P(L,L1,2),";",1)
-	W ?42,"VA Auspices: ",$S($P(B(70),U,5)=1:"YES",$P(B(70),U,5)=2:"NO",1:"")
-	W ! S Z=7 D Z W " Receiv facil: " S Z=$P(B(70),U,12)_$P(B(70),U,13),Z1=18 D Z1 W ?38 S Z="Other Fields" D Z
-	S DGINC=$P(B(101),U,7)
-	I DGINC>1000 S DGINC=$E(DGINC,1,$L(DGINC)-3)_","_$E(DGINC,$L(DGINC)-2,$L(DGINC))
-	W !,"      C&P Status: " S L=";"_$P(^DD(45,78,0),U,3),L1=";"_$P(B(70),U,9)_":" W $E($P($P(L,L1,2),";",1),1,24),?47,"Income: $",DGINC
-	K DGINC
-AS	;
-	N DGRSC
-	S DGRSC=$S($P(A(.3),U)="Y":$$RTEN^DGPTR4($P(A(.3),U,2)),1:"")
-	W !,"       ASIH Days: ",$P(B(70),U,8)
-	W ?40,"SC Percentage: ",$S($P(A(.3),U)="Y":$P(A(.3),U,2)_"%",1:"")
-	I DGRSC]"",DGRSC'=$P(A(.3),U,2) W ?60,"Transmitted: ["_DGRSC_"%]"
-	;W !,?39,"Period Of Serv: ",$S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+$P(A(.32),U,3),+^("ODS"):+$O(^DIC(21,"D",6,0)),1:+$P(A(.32),U,3)),0)):$E($P(^(0),U),1,26),1:""),!
-	W !,?39,"Period Of Serv: "
-	W $S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3)),+^("ODS"):+$O(^DIC(21,"D",6,0)),1:$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3))),0)):$E($P(^(0),U),1,26),1:""),!
-	Q
-	;
-EN1	;LOAD AND DISPLAY DIAGNOSES FOR PTF 701 SCREEN
-	K DRG S B(70)=$S($D(^DGPT(PTF,70)):^(70),1:""),B(71)=$S($D(^DGPT(PTF,71)):^(71),1:"") D WR
-	S DGPTDAT=$$GETDATE^ICDGTDRG(PTF) ;Get correct effective date
-	S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,10),DGPTDAT)
-	W ! S Z=1 D Z W "  Principal Diagnosis: ",$S(DGPTTMP&$P(DGPTTMP,U,10):$P(DGPTTMP,U,4)_"("_$P(DGPTTMP,U,2)_")",1:"")
-	S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,11),DGPTDAT)
-	W:$P(B(70),U,11)&('$P(B(70),U,10)) !,"  Principal Diag: ",$S(DGPTTMP&$P(DGPTTMP,U,10):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"")
-	S K=B(70) F I=16:1:24 D DSP
-	S K=B(71) F I=1:1:4 D DSP
-	S DGPTF=PTF D:'DGST CHK701^DGPTSCAN,UP701^DGPTSPQ
-	; display contents of 300th node 
-	S DG300=$S($D(^DGPT(PTF,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300
-EN2	K DRG
-	I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 D
-	.S DA=DFN
-	.D EN1^DGPTFD
-	.I $D(DRG),$D(^DGP(45.84,PTF,0)),$P(^(0),U,6)'=DRG D
-	..N DGFDA,DGMSG
-	..S DGFDA(45.84,PTF_",",6)=DRG
-	..D FILE^DIE("","DGFDA","DGMSG")
-JUMP	K AGE,B,CC,DA,DAM,DOB,DXLS,EXP,I,L1,L2,SEX,DRGCAL,S,DIC,DR,DIE
-	Q:DGPR
-	;F I=$Y:1:18 W !
-	K X S $P(X,"-",81)="" W X
-	;
-	G O:DGST&(('$D(DRG))!('DGDD)!('$D(^DGP(45.84,PTF))))
-X	G ACT^DGPTF41
-CLS	G NOT:('$D(DRG))!('DGDD)!('DGFC)
-	;I DRG=470!(DRG=469) W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
-	;
-	;change made to allow release of 470, before grouper released to vamc's
-	;  patch 115
-	;DGDAT = effective date of DRG used in DGPTICD (468=CMS-DRG,998=MS-DRG)
-	I DRG=469,(+$G(DGDAT)<3071001)  W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
-	I DRG=998 W !!,*7,"Unable to release DRG ",DRG,".  Please verify data entered.",*7 D HANG^DGPTUTL G EN1
-	I $D(DGCST),'DGCST D CEN G EN1:'DGCST
-	I '$P(^DGPT(PTF,0),"^",4) W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
-	I DGDD>(DT+1) W !,"Cannot close with Discharge date in future." D HANG^DGPTUTL G EN1
-	I $D(^DGM("PT",DFN)) F I=0:0 S I=$O(^DGM("PT",DFN,I)) Q:'I  I '$D(^DGM(I,0)) K ^DGM(I),^DGM("PT",DFN,I)
-	I $D(^DGM("PT",DFN)) W !!,"Not all messages have been cleared up for this patient--cannot close.",*7,*7 S DGPTF=DFN,X="??" K DGALL D HELP^DGPTMSGD K DGPTF G EN1:'$D(DGALL) K DGALL
-	G CLS^DGPTF2
-	;
-O	I '$D(^DGP(45.84,PTF,0)) S DR="6///0",DIE="^DGPT(",DA=PTF,(DGST,DGN)=0 D ^DIE W !,"  NOT CLOSED " D HANG^DGPTUTL G EN1
-	S (DGST,DGN)=0
-	S DGPTIFN=PTF,DGRTY=1 D OPEN^DGPTFDEL S DGST=0
-	K DGPTIFN,DGRTY G EN1
-	;
-Q	G Q^DGPTF
-	;
-NOT	I 'DGFC S DR="3//^S X=$P($$SITE^VASITE,U,2);5",DIE="^DGPT(",DA=PTF D ^DIE S DGFC=$P(^DGPT(PTF,0),U,3) I DGFC G EN1
-	W !!,"Unable to close without a ",$S('$D(DRG):"DRG being calculated.",'DGDD:" discharge date.",1:" facility specified"),!!,*7,*7 H 4 G EN1
-	Q
-	;
-Z	D Z^DGPTF5 Q
-Z1	D Z1^DGPTF5 Q
-CEN	D CEN^DGPTF5 Q
-DSP	S J=$$ICDDX^ICDCODE(+$P(K,U,I),DGPTDAT) I J&$P(J,U,10) D
-	.I I#2 W ?40,$P(J,U,4)_"("_$P(J,U,2)_")" Q
-	.W !,$P(J,U,4)_"("_$P(J,U,2)_")"
-	Q
+DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 2/19/04 9:33am
+ ;;5.3;Registration;**114,115,397,510,517,478,683**;Aug 13, 1993
+ ;
+WR ;
+ W @IOF,HEAD,?72 S Z="<701>" D Z^DGPTFM K X S $P(X,"-",81)="" W !,X
+ Q
+EN S Y=+B(70) D D^DGPTUTL W ! S Z=5 D Z W $S($P(B(0),U,11)=1:"Date of Disch: ",1:"Census Date  : ") S Z=Y,Z1=20 D Z1 W "Disch Specialty: ",$S($D(^DIC(42.4,+$P(B(70),U,2),0)):$E($P(^(0),U,1),1,25),1:"")
+ W !,"   Type of Disch: " S L=";"_$P(^DD(45,72,0),U,3),L1=";"_$P(B(70),U,3)_":" W $P($P(L,L1,2),";",1),?41 S L=";"_$P(^DD(45,72.1,0),U,3),L1=";"_$P(B(70),U,14)_":" W "Disch Status: ",$P($P(L,L1,2),";",1)
+ W !,"   Place of Disp: ",$S($D(^DIC(45.6,+$P(B(70),U,6),0)):$E($P(^(0),U,1),1,21),1:"")
+ W ?40 S Z=6 D Z W " Out Treat: ",$P("YES^^NO",U,+$P(B(70),U,4))
+ W !?6,"Means Test: " S L=";"_$P(^DD(45,10,0),U,3),L1=";"_$P(B(0),U,10)_":" W $P($P(L,L1,2),";",1)
+ W ?42,"VA Auspices: ",$S($P(B(70),U,5)=1:"YES",$P(B(70),U,5)=2:"NO",1:"")
+ W ! S Z=7 D Z W " Receiv facil: " S Z=$P(B(70),U,12)_$P(B(70),U,13),Z1=18 D Z1 W ?38 S Z="Other Fields" D Z
+ S DGINC=$P(B(101),U,7)
+ I DGINC>1000 S DGINC=$E(DGINC,1,$L(DGINC)-3)_","_$E(DGINC,$L(DGINC)-2,$L(DGINC))
+ W !,"      C&P Status: " S L=";"_$P(^DD(45,78,0),U,3),L1=";"_$P(B(70),U,9)_":" W $E($P($P(L,L1,2),";",1),1,24),?47,"Income: $",DGINC
+ K DGINC
+AS ;
+ N DGRSC
+ S DGRSC=$S($P(A(.3),U)="Y":$$RTEN^DGPTR4($P(A(.3),U,2)),1:"")
+ W !,"       ASIH Days: ",$P(B(70),U,8)
+ W ?40,"SC Percentage: ",$S($P(A(.3),U)="Y":$P(A(.3),U,2)_"%",1:"")
+ I DGRSC]"",DGRSC'=$P(A(.3),U,2) W ?60,"Transmitted: ["_DGRSC_"%]"
+ ;W !,?39,"Period Of Serv: ",$S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+$P(A(.32),U,3),+^("ODS"):+$O(^DIC(21,"D",6,0)),1:+$P(A(.32),U,3)),0)):$E($P(^(0),U),1,26),1:""),!
+ W !,?39,"Period Of Serv: "
+ W $S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3)),+^("ODS"):+$O(^DIC(21,"D",6,0)),1:$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3))),0)):$E($P(^(0),U),1,26),1:""),!
+ Q
+ ;
+EN1 ;LOAD AND DISPLAY DIAGNOSES FOR PTF 701 SCREEN
+ K DRG S B(70)=$S($D(^DGPT(PTF,70)):^(70),1:""),B(71)=$S($D(^DGPT(PTF,71)):^(71),1:"") D WR
+ S DGPTDAT=$$GETDATE^ICDGTDRG(PTF) ;Get correct effective date
+ S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,10),DGPTDAT)
+ W ! S Z=1 D Z W "  Principal Diagnosis: ",$S(DGPTTMP&$P(DGPTTMP,U,10):$P(DGPTTMP,U,4)_"("_$P(DGPTTMP,U,2)_")",1:"")
+ S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,11),DGPTDAT)
+ W:$P(B(70),U,11)&('$P(B(70),U,10)) !,"  Principal Diag: ",$S(DGPTTMP&$P(DGPTTMP,U,10):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"")
+ S K=B(70) F I=16:1:24 D DSP
+ S K=B(71) F I=1:1:4 D DSP
+ S DGPTF=PTF D:'DGST CHK701^DGPTSCAN,UP701^DGPTSPQ
+ ; display contents of 300th node 
+ S DG300=$S($D(^DGPT(PTF,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300
+EN2 K DRG
+ I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 D
+ .S DA=DFN
+ .D EN1^DGPTFD
+ .I $D(DRG),$D(^DGP(45.84,PTF,0)),$P(^(0),U,6)'=DRG D
+ ..N DGFDA,DGMSG
+ ..S DGFDA(45.84,PTF_",",6)=DRG
+ ..D FILE^DIE("","DGFDA","DGMSG")
+JUMP K AGE,B,CC,DA,DAM,DOB,DXLS,EXP,I,L1,L2,SEX,DRGCAL,S,DIC,DR,DIE
+ Q:DGPR
+ ;F I=$Y:1:18 W !
+ K X S $P(X,"-",81)="" W X
+ ;
+ G O:DGST&(('$D(DRG))!('DGDD)!('$D(^DGP(45.84,PTF))))
+X G ACT^DGPTF41
+CLS G NOT:('$D(DRG))!('DGDD)!('DGFC)
+ ;I DRG=470!(DRG=469) W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
+ ;
+ ;change made to allow release of 470, before grouper released to vamc's
+ ;  patch 115
+ I DRG=469 W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
+ I $D(DGCST),'DGCST D CEN G EN1:'DGCST
+ I '$P(^DGPT(PTF,0),"^",4) W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
+ I DGDD>(DT+1) W !,"Cannot close with Discharge date in future." D HANG^DGPTUTL G EN1
+ I $D(^DGM("PT",DFN)) F I=0:0 S I=$O(^DGM("PT",DFN,I)) Q:'I  I '$D(^DGM(I,0)) K ^DGM(I),^DGM("PT",DFN,I)
+ I $D(^DGM("PT",DFN)) W !!,"Not all messages have been cleared up for this patient--cannot close.",*7,*7 S DGPTF=DFN,X="??" K DGALL D HELP^DGPTMSGD K DGPTF G EN1:'$D(DGALL) K DGALL
+ G CLS^DGPTF2
+ ;
+O I '$D(^DGP(45.84,PTF,0)) S DR="6///0",DIE="^DGPT(",DA=PTF,(DGST,DGN)=0 D ^DIE W !,"  NOT CLOSED " D HANG^DGPTUTL G EN1
+ S (DGST,DGN)=0
+ S DGPTIFN=PTF,DGRTY=1 D OPEN^DGPTFDEL S DGST=0
+ K DGPTIFN,DGRTY G EN1
+ ;
+Q G Q^DGPTF
+ ;
+NOT I 'DGFC S DR="3//^S X=$P($$SITE^VASITE,U,2);5",DIE="^DGPT(",DA=PTF D ^DIE S DGFC=$P(^DGPT(PTF,0),U,3) I DGFC G EN1
+ W !!,"Unable to close without a ",$S('$D(DRG):"DRG being calculated.",'DGDD:" discharge date.",1:" facility specified"),!!,*7,*7 H 4 G EN1
+ Q
+ ;
+Z D Z^DGPTF5 Q
+Z1 D Z1^DGPTF5 Q
+CEN D CEN^DGPTF5 Q
+DSP S J=$$ICDDX^ICDCODE(+$P(K,U,I),DGPTDAT) I J&$P(J,U,10) D
+ .I I#2 W ?40,$P(J,U,4)_"("_$P(J,U,2)_")" Q
+ .W !,$P(J,U,4)_"("_$P(J,U,2)_")"
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFDEL.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFDEL.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFDEL.m	(revision 623)
@@ -1,72 +1,73 @@
-DGPTFDEL	;ALB/JDS - PTF ENTRY DELETION ; 7/31/07 11:19am
-	;;5.3;Registration;**517,760**;Aug 13, 1993;Build 11
-	;
-A	D LO^DGUTL I $D(^DISV(DUZ,"^DPT(")),$D(^("^DGPT(")) S A=+^("^DGPT("),B=+^("^DPT(") I $D(^DGPT(A,0)),$D(^DPT(B,0)) S:(+^DGPT(A,0)'=B&$D(^DGPT("B",B))) ^DISV(DUZ,"^DGPT(")=""
-	Q
-	;
-ASK	D A W !!
-	S Y=1 D RTY^DGPTUTL
-	S DIC("S")="I $P(^(0),U,11)=1,'$D(^DGP(45.84,+Y))",DIC="^DGPT(",DIC(0)="NEAQ",DIC("A")="Enter PTF record to delete: "
-	D ^DIC G Q:Y'>0 S DA=+Y,DIC(0)="NE",X=DA D CEN G ASK:'$D(DA)
-A1	W !! D ^DIC S %=2 W !,"Ok to delete" D YN^DICN
-	I %=1 S DGPTIFN=DA D KDGPT W !,"****** DELETED ******" D HANG^DGPTUTL G Q
-AD	I '% W !,"Anwer Yes or No",!,"On deletion pointers will be updated" G A1
-	;
-	;
-Q	K DA,DFN,A,B,L,I,ANS,DIE,DR,DIK,DIC,DGRTY,DGRTY0,DGPTIFN Q
-	;
-HEL	;
-	I '$D(DGRTY) S Y=1 D RTY^DGPTUTL
-	D A W !!
-	S DIC(0)="NEAQ",DIC="^DGP(45.84,",DIC("S")="I '$D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$P(^(0),U,11)="_DGRTY,DIC("A")="Enter "_$P(DGRTY0,U)_" record to re-open: "
-	D ^DIC G Q:Y'>0 S (X,DGPTIFN)=+Y,%=2
-A2	I '% W !!,DGPTIFN,"  ",$P(^DPT(+^DGPT(DGPTIFN,0),0),U) S DGSENFLG="",X=DGPTIFN,DIC(0)="NE",DIC="^DGP(45.84," D ^DIC K DIC,DGSENFLG
-	I DGRTY=2 D CHK G Q:'DGPTIFN
-	S %=2 W !,"Ok to reactivate" D YN^DICN
-	I '% W !,"Answer Yes or No" G A2
-	G Q:%'=1
-	D OPEN G Q
-	;
-OLD	I '$D(^DISV(DUZ,"PTFAD",DFN)) W "  ???",*7,*7 G AD
-	S X=^(DFN)
-	Q
-DREL	; -- open released rec
-	I '$D(DGRTY) S Y=1 D RTY^DGPTUTL
-	W ! S DIC("A")="Enter Released "_$P(DGRTY0,U)_" Record to Re-open: ",DIC("S")="I $D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$D(^(70)),+^(70)>2901000,$P(^(0),U,11)="_DGRTY,DIC="^DGP(45.84,",DIC(0)="MEQA"
-	D ^DIC K DIC G Q:+Y'>0 S DGPTIFN=+Y
-	I DGRTY=2 D CHK G Q:'DGPTIFN
-OK	W !,"Ok to Re-open" S %=2 D YN^DICN
-	I '% W !!?14,"Enter <RET> to exit routine",!?10,"Enter 'Y' for YES to RE-OPEN Record",! G OK
-	G Q:%'=1
-	S DA(1)=$O(^DGP(45.83,"C",DGPTIFN,0)) I DA(1) S DIK="^DGP(45.83,"_DA(1)_",""P"",",DA=DGPTIFN D ^DIK K DIK,DA
-	D OPEN G Q
-	;
-OPEN	;
-	D KDGP,KDGPT:DGRTY=2
-	W !,"****** RECORD RE-OPENED ******" D HANG^DGPTUTL
-	Q
-	;
-KDGP	; -- kill close-out rec ; input DGPTIFN := ifn
-	S DA=DGPTIFN,DIK="^DGP(45.84," D ^DIK K DIK,DA
-	Q
-	;
-KDGPT	; -- kill DGPT rec ; input DGPTIFN := ifn
-	S DA=DGPTIFN,DIK="^DGPT(",FLAG=1,I=0 F  S I=$O(^DGCPT(46,"C",DA,I)) Q:'I  I '$G(^DGCPT(46,I,9)) S FLAG=0 Q
-	I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT RECORDS." H 2 K FLAG Q
-	D ^DIK K DA,DIK,I,FLAG
-	I DGRTY=1 S DA=+$O(^DGPM("APTF",DGPTIFN,0)) I $D(^DGPM(DA,0)),$P(^(0),U,16)=DGPTIFN S DR=".16///@",DIE="^DGPM(" D ^DIE K DR,DIE
-	K DA Q
-	;
-CHK	; -- check to see if PTF is open ; return DGPTIFN="" is not open
-	I $D(^DGPT(+$P(^DGPT(DGPTIFN,0),U,12),0)),$P(^(0),U,6) W !!,*7,?5,"Associated PTF record #",+$P(^DGPT(DGPTIFN,0),U,12)," must be RE-OPENED",!?5,"in order to re-open Census record #",DGPTIFN,"." S DGPTIFN=""
-	Q
-	;
-CEN	; -- check if closed for census
-	K DGI
-	F DGI=0:0 S DGI=$O(^DGPT("ACENSUS",DA,DGI)) Q:'DGI  I $D(^DGPT(DGI,0)),$P(^(0),U,12)=DA,$D(^DG(45.86,+$P(^(0),U,13),0)) S Y=+^(0) X ^DD("DD") S DGI(DGI)=Y
-	G CENQ:$D(DGI)<10
-	W !!?2,*7,"This PTF record is associated with the following Census records:"
-	F DGI=0:0 S DGI=$O(DGI(DGI)) Q:'DGI  W !?10,"Census Record #",DGI,?35,"==>",?40,"Census Date: ",DGI(DGI)
-	W !!?2,"PTF record can not be deleted."
-	K DA
-CENQ	K DGI Q
+DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 1/15/04 8:23am
+ ;;5.3;Registration;**517**;Aug 13, 1993
+ ;
+A D LO^DGUTL I $D(^DISV(DUZ,"^DPT(")),$D(^("^DGPT(")) S A=+^("^DGPT("),B=+^("^DPT(") I $D(^DGPT(A,0)),$D(^DPT(B,0)) S:(+^DGPT(A,0)'=B&$D(^DGPT("B",B))) ^DISV(DUZ,"^DGPT(")=""
+ Q
+ ;
+ASK D A W !!
+ S Y=1 D RTY^DGPTUTL
+ S DIC("S")="I $P(^(0),U,11)=1,'$D(^DGP(45.84,+Y))",DIC="^DGPT(",DIC(0)="NEAQ",DIC("A")="Enter PTF record to delete: "
+ D ^DIC G Q:Y'>0 S DA=+Y,DIC(0)="NE",X=DA D CEN G ASK:'$D(DA)
+A1 W !! D ^DIC S %=2 W !,"Ok to delete" D YN^DICN
+ I %=1 S DGPTIFN=DA D KDGPT W !,"****** DELETED ******" D HANG^DGPTUTL G Q
+AD I '% W !,"Anwer Yes or No",!,"On deletion pointers will be updated" G A1
+ ;
+ ;
+Q K DA,DFN,A,B,L,I,ANS,DIE,DR,DIK,DIC,DGRTY,DGRTY0,DGPTIFN Q
+ ;
+HEL ;
+ I '$D(DGRTY) S Y=1 D RTY^DGPTUTL
+ D A W !!
+ S DIC(0)="NEAQ",DIC="^DGP(45.84,",DIC("S")="I '$D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$P(^(0),U,11)="_DGRTY,DIC("A")="Enter "_$P(DGRTY0,U)_" record to re-open: "
+ D ^DIC G Q:Y'>0 S (X,DGPTIFN)=+Y,%=2
+A2 I '% W !!,DGPTIFN,"  ",$P(^DPT(+^DGPT(DGPTIFN,0),0),U) S DGSENFLG="",X=DGPTIFN,DIC(0)="NE",DIC="^DGP(45.84," D ^DIC K DIC,DGSENFLG
+ I DGRTY=2 D CHK G Q:'DGPTIFN
+ S %=2 W !,"Ok to reactivate" D YN^DICN
+ I '% W !,"Answer Yes or No" G A2
+ G Q:%'=1
+ D OPEN G Q
+ ;
+OLD I '$D(^DISV(DUZ,"PTFAD",DFN)) W "  ???",*7,*7 G AD
+ S X=^(DFN)
+ Q
+DREL ; -- open released rec
+ I '$D(DGRTY) S Y=1 D RTY^DGPTUTL
+ W ! S DIC("A")="Enter Released "_$P(DGRTY0,U)_" Record to Re-open: ",DIC("S")="I $D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$D(^(70)),+^(70)>2901000,$P(^(0),U,11)="_DGRTY,DIC="^DGP(45.84,",DIC(0)="MEQA"
+ D ^DIC K DIC G Q:+Y'>0 S DGPTIFN=+Y
+ I DGRTY=2 D CHK G Q:'DGPTIFN
+OK W !,"Ok to Re-open" S %=2 D YN^DICN
+ I '% W !!?14,"Enter <RET> to exit routine",!?10,"Enter 'Y' for YES to RE-OPEN Record",! G OK
+ G Q:%'=1
+ S DA(1)=$O(^DGP(45.83,"C",DGPTIFN,0)) I DA(1) S DIK="^DGP(45.83,"_DA(1)_",""P"",",DA=DGPTIFN D ^DIK K DIK,DA
+ D OPEN G Q
+ ;
+OPEN ;
+ D KDGP,KDGPT:DGRTY=2
+ W !,"****** RECORD RE-OPENED ******" D HANG^DGPTUTL
+ Q
+ ;
+KDGP ; -- kill close-out rec ; input DGPTIFN := ifn
+ S DA=DGPTIFN,DIK="^DGP(45.84," D ^DIK K DIK,DA
+ Q
+ ;
+KDGPT ; -- kill DGPT rec ; input DGPTIFN := ifn
+ S DA=DGPTIFN,DIK="^DGPT(",FLAG=1,I=0 F  S I=$O(^DGCPT(46,"C",DA,I)) Q:'I  I '$G(^DGCPT(I,9)) S FLAG=0 Q
+ I FLAG S I=0 F  S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I  I '$G(^DGICD9(I,9)) S FLAG=0 Q
+ I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT RECORDS." H 2 K FLAG Q
+ D ^DIK K DA,DIK,I,FLAG
+ I DGRTY=1 S DA=+$O(^DGPM("APTF",DGPTIFN,0)) I $D(^DGPM(DA,0)),$P(^(0),U,16)=DGPTIFN S DR=".16///@",DIE="^DGPM(" D ^DIE K DR,DIE
+ K DA Q
+ ;
+CHK ; -- check to see if PTF is open ; return DGPTIFN="" is not open
+ I $D(^DGPT(+$P(^DGPT(DGPTIFN,0),U,12),0)),$P(^(0),U,6) W !!,*7,?5,"Associated PTF record #",+$P(^DGPT(DGPTIFN,0),U,12)," must be RE-OPENED",!?5,"in order to re-open Census record #",DGPTIFN,"." S DGPTIFN=""
+ Q
+ ;
+CEN ; -- check if closed for census
+ K DGI
+ F DGI=0:0 S DGI=$O(^DGPT("ACENSUS",DA,DGI)) Q:'DGI  I $D(^DGPT(DGI,0)),$P(^(0),U,12)=DA,$D(^DG(45.86,+$P(^(0),U,13),0)) S Y=+^(0) X ^DD("DD") S DGI(DGI)=Y
+ G CENQ:$D(DGI)<10
+ W !!?2,*7,"This PTF record is associated with the following Census records:"
+ F DGI=0:0 S DGI=$O(DGI(DGI)) Q:'DGI  W !?10,"Census Record #",DGI,?35,"==>",?40,"Census Date: ",DGI(DGI)
+ W !!?2,"PTF record can not be deleted."
+ K DA
+CENQ K DGI Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM4.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM4.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM4.m	(revision 623)
@@ -1,77 +1,74 @@
-DGPTFM4	;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 12/18/07 11:37am
-	;;5.3;Registration;**114,195,397,510,565,775**;Aug 13, 1993;Build 3
-	;;ADL;Update for CSV Project;;Mar 26, 2003
-	;
-	S DGZM0=DGZM0+1
-EN	N M3 D MOB:'$D(M) S M(DGZM0)=$S($D(M(DGZM0)):M(DGZM0),1:"") G NEXM:M(DGZM0)="" S (M3,M(DGZM0),M1)=$S($D(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"")
-	I $D(^DGPT(PTF,"M",+M(DGZM0),"P")) S $P(M(DGZM0),U,20)=^("P"),$P(M1,U,20)=^("P")
-WR	S DG300=$S($D(^DGPT(PTF,"M",+M(DGZM0),300)):^(300),1:"")
-	W @IOF,HEAD,?70 S Z="<501-"_DGZM0_">" D Z^DGPTFM I +M(DGZM0)=1 W !,?62,"Discharge Movement"
-M	S L=+$P(M1,U,10),Y=L D D^DGPTUTL W !! S Z=1 D Z W "Date of Move: " S Z=Y,Z1=20 D Z1 W "Losing Specialty: ",$E($S($D(^DIC(42.4,+$P(M1,U,2),0)):$P(^(0),U,1),1:""),1,25)
-	W !,"     Leave days: ",$P(M1,U,3),?44,"Pass days: ",$P(M1,U,4)
-	W !,"Treated for SC Condition: ",$S($P(M3,U,18)=1:"Yes",1:"No")
-	N NL S NL=0
-	I $P(M3,U,31)'="" W @($S(NL#2:"!",1:"?37")),"Potentially Related to Combat: ",$S($P(M3,U,31)="Y":"Yes",1:"No") S NL=NL+1
-	I $P(M3,U,26)'="" W @($S(NL#2:"!",1:"?37")),"Treated for AO Condition: ",$S($P(M3,U,26)="Y":"Yes",1:"No") S NL=NL+1
-	I $P(M3,U,27)'="" W @($S(NL#2:"!",1:"?37")),"Treated for IR Condition: ",$S($P(M3,U,27)="Y":"Yes",1:"No") S NL=NL+1
-	I $P(M3,U,28)'="" W @($S(NL#2:"!",1:"?37")),"Treated for EC Condition: ",$S($P(M3,U,28)="Y":"Yes",1:"No") S NL=NL+1
-	; added 6/17/98 for MST enhancement
-	I $P(M3,U,29)'="" W @($S(NL#2:"!",1:"?37")),"Treated for MST Condition: ",$S($P(M3,U,29)="Y":"Yes",1:"No") S NL=NL+1
-	K DGNTARR
-	S DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR")
-	I $P(M3,U,30)="",(",3,4,5,"[(","_$P($G(DGNTARR("STAT")),U)_",")) S $P(M3,U,30)="N"
-	I $P(M3,U,30)'="" W @($S(NL#2:"!",1:"?37")),"Treated for HEAD/NECK CA Condition: ",$S($P(M3,U,30)="Y":"Yes",1:"No")
-	K NL
-	W !! S Z=2 D Z W "          DX: " F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) S DGPTTMP=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)) D 
-	. W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
-	D PRN2^DGPTFM8:DG300]""
-	I $P(M1,U,20) S DRG=$P(M1,U,20) W:DRG=998!(DRG=999)!((DRG=468!(DRG=469)!(DRG=470))&(+$P($G(M1),U,10)<3071001)) *7 W !!?14,"TRANSFER DRG: ",DRG D
-	. N DXD,DGDX
-	. S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$P(M1,U,10)),DGDS=0
-	. F  S DGDS=$O(DGDX(DGDS)) Q:'+DGDS  Q:DGDX(DGDS)=" "  W !,DGDX(DGDS)
-JUMP	K DG300 F I=$Y:1:21 W !
-X	S DGNUM=$S($D(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS") G 501^DGPTFJC:DGST
-	W "Enter <RET> to continue, 1-2 to edit,",!,"'M' ",$S(DGPTFE:" to add a patient movement",1:"to edit Treat. Specialty"),", '^N' for screen N, or '^' to abort:<",DGNUM,">// " R X:DTIME
-	K DGNUM G Q:X="^",NEXM:X="",^DGPTFJ:X?1"^".E,M^DGPTFM1:X="M"!(X="m")
-X1	I X[1!(X[2) S DR="[DG501"_$E("F",DGPTFE) X:(+M(DGZM0)=1) "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_1" S DR=DR_"]",DGJUMP=X,DIE="^DGPT(",(DA,DGPTF)=PTF,DGMOV=+M(DGZM0) D ^DIE K M,DR,DIE D CHK501^DGPTSCAN K DGPTF,DGMOV
-	; Determine if NTR HISTORY (#28.11) filer is called if question for
-	;  'Treated for Head/Neck CA Condition:' is answered YES.
-	; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed.
-	I $P($G(M3),U,30)="Y",$P($G(DGNTARR("STAT")),U)=3 D
-	.S DGNTARR=$$FILEHNC^DGNTAPI1(DFN)
-	K DGNTARR
-	;- update MT indicator after edit movement
-	N DGPMCA,DGPMAN D PM^DGPTUTL
-	I '$G(DGADM) S DGADM=+^DGPT(PTF,0)
-	D MT^DGPTUTL
-	G EN
-PR	W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"
-	W !?10,"1-",$S(DGPTFE:"Date of movement, Losing Specialty, ",1:""),"Leave and Pass days",!?10,"2-ICD DIAGNOSIS CODES"
-	W !,"You may also enter 1-2",!
-	R !!,"Enter <RET>: ",X:DTIME G WR
-	Q
-NEXM	S DGZM0=DGZM0+1 G ^DGPTFM:'$D(M(DGZM0)),EN
-ADD	S DGZM0=$S($D(DGZM0):DGZM0+1,1:0) S L=$S($D(^DGPT(PTF,"M",0)):^(0),1:"^45.02DA^^"),L1=$P(L,U,3) F I=1:1 Q:'$D(^DGPT(PTF,"M",L1+I))
-	S DA(1)=PTF,DIC="^DGPT("_DA(1)_",""M"",",X=L1+I,DIC(0)="LMZQE" D ^DIC K DIC,DIE G ^DGPTFM:Y'>0
-	S M(DGZM0)=L1+I S X="1-2" G X1
-	Q
-MOB	S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I  S M(I1)=^(I,0)
-	S PM=I1-1 D ORDER^DGPTF Q
-Q	G Q^DGPTF
-Z	I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO
-	E  W "   "
-	Q
-Z1	F I=1:1:(Z1-$L(Z)) S Z=Z_" "
-	W Z
-	Q
-R	;DELETE PROCEDURE RECORD
-	I '$D(^DGPT(PTF,"P")) G NOPROC
-	I $O(^DGPT(PTF,"P",0))']"" G NOPROC
-	S DGPNUM="" F DGPROC=0:0 S DGPROC=$O(P(DGPROC)) Q:'DGPROC  S:$D(P(DGPROC,1)) DGPNUM=DGPNUM_","_DGPROC
-	S DGPNUM=DGPNUM_","
-ASKPRO	W !!,"Delete procedure record <",$P(DGPNUM,",",2,99),"> : " R DGPROC:DTIME I DGPROC[U!(DGPROC="") K DGPNUM,DGPROC G ^DGPTFM
-	I DGPNUM'[(","_DGPROC_",") W !!,"Enter the record # to delete from the PTF file <",$P(DGPNUM,",",2,99),">",! G ASKPRO
-	K DA N DGJ
-	F DGJ=1:1 S DA=+$P(DGPROC,",",DGJ) Q:'DA  S DA=$S($D(P(DA,1)):+P(DA,1),1:0) I DA S DA(1)=PTF,DIK="^DGPT("_PTF_",""P""," D ^DIK K DA W "   ",$P(DGPROC,",",DGJ),"-DELETED***" H:'$P(DGPROC,",",DGJ+1) 2
-	K DIK,DA,DGPROC,DGPNUM G ^DGPTFM
-NOPROC	W !!,*7,"No procedures to delete",! H 3 G ^DGPTFM
+DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 11/19/03 11:37am
+ ;;5.3;Registration;**114,195,397,510,565**;Aug 13, 1993
+ ;;ADL;Update for CSV Project;;Mar 26, 2003
+ ;
+ S DGZM0=DGZM0+1
+EN N M3 D MOB:'$D(M) S M(DGZM0)=$S($D(M(DGZM0)):M(DGZM0),1:"") G NEXM:M(DGZM0)="" S (M3,M(DGZM0),M1)=$S($D(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"")
+ I $D(^DGPT(PTF,"M",+M(DGZM0),"P")) S $P(M(DGZM0),U,20)=^("P"),$P(M1,U,20)=^("P")
+WR S DG300=$S($D(^DGPT(PTF,"M",+M(DGZM0),300)):^(300),1:"")
+ W @IOF,HEAD,?70 S Z="<501-"_DGZM0_">" D Z^DGPTFM I +M(DGZM0)=1 W !,?62,"Discharge Movement"
+M S L=+$P(M1,U,10),Y=L D D^DGPTUTL W !! S Z=1 D Z W "Date of Move: " S Z=Y,Z1=20 D Z1 W "Losing Specialty: ",$E($S($D(^DIC(42.4,+$P(M1,U,2),0)):$P(^(0),U,1),1:""),1,25)
+ W !,"     Leave days: ",$P(M1,U,3),?44,"Pass days: ",$P(M1,U,4)
+ W !,"Treated for SC Condition: ",$S($P(M3,U,18)=1:"Yes",1:"No")
+ N NL S NL=0
+ I $P(M3,U,31)'="" W @($S(NL#2:"!",1:"?37")),"Potentially Related to Combat: ",$S($P(M3,U,31)="Y":"Yes",1:"No") S NL=NL+1
+ I $P(M3,U,26)'="" W @($S(NL#2:"!",1:"?37")),"Treated for AO Condition: ",$S($P(M3,U,26)="Y":"Yes",1:"No") S NL=NL+1
+ I $P(M3,U,27)'="" W @($S(NL#2:"!",1:"?37")),"Treated for IR Condition: ",$S($P(M3,U,27)="Y":"Yes",1:"No") S NL=NL+1
+ I $P(M3,U,28)'="" W @($S(NL#2:"!",1:"?37")),"Treated for EC Condition: ",$S($P(M3,U,28)="Y":"Yes",1:"No") S NL=NL+1
+ ; added 6/17/98 for MST enhancement
+ I $P(M3,U,29)'="" W @($S(NL#2:"!",1:"?37")),"Treated for MST Condition: ",$S($P(M3,U,29)="Y":"Yes",1:"No") S NL=NL+1
+ K DGNTARR
+ S DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR")
+ I $P(M3,U,30)="",(",3,4,5,"[(","_$P($G(DGNTARR("STAT")),U)_",")) S $P(M3,U,30)="N"
+ I $P(M3,U,30)'="" W @($S(NL#2:"!",1:"?37")),"Treated for HEAD/NECK CA Condition: ",$S($P(M3,U,30)="Y":"Yes",1:"No")
+ K NL
+ W !! S Z=2 D Z W "          DX: " F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) S DGPTTMP=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)) D 
+ . W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
+ D PRN2^DGPTFM8:DG300]""
+ I $P(M1,U,20) S DRG=$P(M1,U,20) W:DRG=468!(DRG=469)!(DRG=470) *7 W !!?14,"TRANSFER DRG: ",DRG F DGDRGNM=0:0 S DGDRGNM=$O(^ICD(DRG,1,DGDRGNM)) Q:'DGDRGNM  W !,$P(^(DGDRGNM,0),U,1)
+JUMP K DG300 F I=$Y:1:21 W !
+X S DGNUM=$S($D(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS") G 501^DGPTFJC:DGST
+ W "Enter <RET> to continue, 1-2 to edit,",!,"'M' ",$S(DGPTFE:" to add a patient movement",1:"to edit Treat. Specialty"),", '^N' for screen N, or '^' to abort:<",DGNUM,">// " R X:DTIME
+ K DGNUM G Q:X="^",NEXM:X="",^DGPTFJ:X?1"^".E,M^DGPTFM1:X="M"!(X="m")
+X1 I X[1!(X[2) S DR="[DG501"_$E("F",DGPTFE) X:(+M(DGZM0)=1) "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_1" S DR=DR_"]",DGJUMP=X,DIE="^DGPT(",(DA,DGPTF)=PTF,DGMOV=+M(DGZM0) D ^DIE K M,DR,DIE D CHK501^DGPTSCAN K DGPTF,DGMOV
+ ; Determine if NTR HISTORY (#28.11) filer is called if question for
+ ;  'Treated for Head/Neck CA Condition:' is answered YES.
+ ; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed.
+ I $P($G(M3),U,30)="Y",$P($G(DGNTARR("STAT")),U)=3 D
+ .S DGNTARR=$$FILEHNC^DGNTAPI1(DFN)
+ K DGNTARR
+ ;- update MT indicator after edit movement
+ N DGPMCA,DGPMAN D PM^DGPTUTL
+ I '$G(DGADM) S DGADM=+^DGPT(PTF,0)
+ D MT^DGPTUTL
+ G EN
+PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"
+ W !?10,"1-",$S(DGPTFE:"Date of movement, Losing Specialty, ",1:""),"Leave and Pass days",!?10,"2-ICD DIAGNOSIS CODES"
+ W !,"You may also enter 1-2",!
+ R !!,"Enter <RET>: ",X:DTIME G WR
+ Q
+NEXM S DGZM0=DGZM0+1 G ^DGPTFM:'$D(M(DGZM0)),EN
+ADD S DGZM0=$S($D(DGZM0):DGZM0+1,1:0) S L=$S($D(^DGPT(PTF,"M",0)):^(0),1:"^45.02DA^^"),L1=$P(L,U,3) F I=1:1 Q:'$D(^DGPT(PTF,"M",L1+I))
+ S DA(1)=PTF,DIC="^DGPT("_DA(1)_",""M"",",X=L1+I,DIC(0)="LMZQE" D ^DIC K DIC,DIE G ^DGPTFM:Y'>0
+ S M(DGZM0)=L1+I S X="1-2" G X1
+ Q
+MOB S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I  S M(I1)=^(I,0)
+ S PM=I1-1 D ORDER^DGPTF Q
+Q G Q^DGPTF
+Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO
+ E  W "   "
+ Q
+Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" "
+ W Z
+ Q
+R ;DELETE PROCEDURE RECORD
+ I '$D(^DGPT(PTF,"P")) G NOPROC
+ I $O(^DGPT(PTF,"P",0))']"" G NOPROC
+ S DGPNUM="" F DGPROC=0:0 S DGPROC=$O(P(DGPROC)) Q:'DGPROC  S:$D(P(DGPROC,1)) DGPNUM=DGPNUM_","_DGPROC
+ S DGPNUM=DGPNUM_","
+ASKPRO W !!,"Delete procedure record <",$P(DGPNUM,",",2,99),"> : " R DGPROC:DTIME I DGPROC[U!(DGPROC="") K DGPNUM,DGPROC G ^DGPTFM
+ I DGPNUM'[(","_DGPROC_",") W !!,"Enter the record # to delete from the PTF file <",$P(DGPNUM,",",2,99),">",! G ASKPRO
+ K DA N DGJ
+ F DGJ=1:1 S DA=+$P(DGPROC,",",DGJ) Q:'DA  S DA=$S($D(P(DA,1)):+P(DA,1),1:0) I DA S DA(1)=PTF,DIK="^DGPT("_PTF_",""P""," D ^DIK K DA W "   ",$P(DGPROC,",",DGJ),"-DELETED***" H:'$P(DGPROC,",",DGJ+1) 2
+ K DIK,DA,DGPROC,DGPNUM G ^DGPTFM
+NOPROC W !!,*7,"No procedures to delete",! H 3 G ^DGPTFM
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m	(revision 623)
@@ -1,62 +1,61 @@
-DGPTICD	;ALB/MTC - PTF DRG Grouper Utility ; 2/19/02 3:08pm
-	;;5.3;Registration;**375,441,510,559,599,606,775**;Aug 13, 1993;Build 3
-	;variables to pass in:
-	;  DGDX <- format: DX CODE1^DX CODE2^DX CODE3^...                      (REQUIRED)
-	;  DGSURG <- format: SURGERY CODE1^SURGERY CODE2^SURGERY CODE3^...       (OPTIONAL)
-	;  DGPROC <- format: PROCEDURE CODE1^PROCEDURE CODE2^PROCEDURE CODE3^... (OPTIONAL)
-	;  DGTRS  <- 1 if patient transferred to acute care facility             (REQUIRED)
-	;  DGEXP  <- 1 if patient died during this episode                       (REQUIRED)
-	;  DGDMS  <- 1 if patient was discharged with an Irregular discharge (discharged against medical advice) (REQUIRED)
-	;  AGE,SEX     (REQUIRED)
-	;values of variables listed above are left unchanged by this routine
-	;variable passed back: DRG(0) <- zero node of DRG in DRG file
-	;                    : DRG <- IFN of DRG in DRG file
-	;  DGDAT  <- Effective date to be used in calculating DRG
-	;
-	;-- check for required variables
-	Q:'$D(DGDX)!'$D(DGTRS)!'$D(DGEXP)!'$D(DGDMS)
-	N DGI
-	;-- build ICDDX array
-	K ICDDX
-	S DGI=0 F  S DGI=DGI+1 Q:$P(DGDX,U,DGI)=""  D
-	. S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGDX,U,DGI),+$G(DGDAT))
-	. I +DGPTTMP>0,($P(DGPTTMP,U,10)) S ICDDX(DGI)=$P(DGDX,U,DGI)
-	G Q:'$D(ICDDX)
-	;
-	;-- build ICDPRC array
-	;K ICDPRC
-	;I $D(DGPROC) S DGSURG=$S('$D(DGSURG):DGPROC,1:DGSURG_DGPROC)
-	;I $D(DGSURG) S DGI=0 F  S DGI=DGI+1 Q:$P(DGSURG,U,DGI)=""  D
-	;. I $D(^ICD0($P(DGSURG,U,DGI),0)) S ICDPRC(DGI)=$P(DGSURG,U,DGI)
-	;-- build ICDPRC array eliminating dupes as we go
-	K ICDPRC
-	N I,J,X,Y,FLG,SUB S SUB=0
-	I $D(DGPROC) F I=2:1 S X=$P(DGPROC,U,I) Q:X=""  D
-	. S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT))
-	. I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
-	I $D(DGSURG) F I=2:1 S X=$P(DGSURG,U,I) Q:X=""  D
-	. S FLG=0,J=0 F  S J=$O(ICDPRC(J)) Q:'J  I X=$G(ICDPRC(J)) S FLG=1 Q
-	. I FLG Q
-	. S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT))
-	. I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
-	;
-	;-- set other required variables
-	S ICDTRS=DGTRS,ICDEXP=DGEXP,ICDDMS=DGDMS
-	S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE  ;Ensure that DGDAT is defined prior to executing PRT
-	;
-	;-- calculate DRG
-	D ^ICDDRG S DRG=ICDDRG I '$D(DGDRGPRT) G Q
-	;
-PRT	;print DRG and national HCFA values
-	I (ICDDATE<3071001)&(DRG=468!(DRG=469)!(DRG=470)) W *7
-	I DRG=998!(DRG=999) W *7
-	S Y=ICDDATE D DD^%DT ; Y=external representation of effective date
-	W !!?9,"Effective Date:","  ",Y
-	S DRG(0)=$$DRG^ICDGTDRG(DRG,DGDAT) W !!,"Diagnosis Related Group: ",$J(DRG,6),?36,"Average Length of Stay(ALOS): ",$J($P(DRG(0),"^",8),6)
-	W !?17,"Weight: ",$J($P(DRG(0),"^",2),6)  ;,?40,"Local Breakeven: ",$J($P(DRG(0),"^",12),6)
-	W !?12," Low Day(s): ",$J($P(DRG(0),"^",3),6)  ;,?39,"Local Low Day(s): ",$J($P(DRG(0),"^",9),6)
-	W !?13," High Days: ",$J($P(DRG(0),"^",4),6)  ;,?40,"Local High Days: ",$J($P(DRG(0),"^",10),6)
-	N DXD,DGDX
-	S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DGDAT),DGI=0
-	W !!,"DRG: ",DRG,"-" F  S DGI=$O(DGDX(DGI)) Q:'+DGI  Q:DGDX(DGI)=" "  W ?10,DGDX(DGI),!
-Q	K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS,ICDDATE Q
+DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ; 2/19/02 3:08pm
+ ;;5.3;Registration;**375,441,510,559,599,606**;Aug 13, 1993
+ ;variables to pass in:
+ ;  DGDX <- format: DX CODE1^DX CODE2^DX CODE3^...                      (REQUIRED)
+ ;  DGSURG <- format: SURGERY CODE1^SURGERY CODE2^SURGERY CODE3^...       (OPTIONAL)
+ ;  DGPROC <- format: PROCEDURE CODE1^PROCEDURE CODE2^PROCEDURE CODE3^... (OPTIONAL)
+ ;  DGTRS  <- 1 if patient transferred to acute care facility             (REQUIRED)
+ ;  DGEXP  <- 1 if patient died during this episode                       (REQUIRED)
+ ;  DGDMS  <- 1 if patient was discharged with an Irregular discharge (discharged against medical advice) (REQUIRED)
+ ;  AGE,SEX     (REQUIRED)
+ ;values of variables listed above are left unchanged by this routine
+ ;variable passed back: DRG(0) <- zero node of DRG in DRG file
+ ;                    : DRG <- IFN of DRG in DRG file
+ ;  DGDAT  <- Effective date to be used in calculating DRG
+ ;
+ ;-- check for required variables
+ Q:'$D(DGDX)!'$D(DGTRS)!'$D(DGEXP)!'$D(DGDMS)
+ N DGI
+ ;-- build ICDDX array
+ K ICDDX
+ S DGI=0 F  S DGI=DGI+1 Q:$P(DGDX,U,DGI)=""  D
+ . S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGDX,U,DGI),+$G(DGDAT))
+ . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S ICDDX(DGI)=$P(DGDX,U,DGI)
+ G Q:'$D(ICDDX)
+ ;
+ ;-- build ICDPRC array
+ ;K ICDPRC
+ ;I $D(DGPROC) S DGSURG=$S('$D(DGSURG):DGPROC,1:DGSURG_DGPROC)
+ ;I $D(DGSURG) S DGI=0 F  S DGI=DGI+1 Q:$P(DGSURG,U,DGI)=""  D
+ ;. I $D(^ICD0($P(DGSURG,U,DGI),0)) S ICDPRC(DGI)=$P(DGSURG,U,DGI)
+ ;-- build ICDPRC array eliminating dupes as we go
+ K ICDPRC
+ N I,J,X,Y,FLG,SUB S SUB=0
+ I $D(DGPROC) F I=2:1 S X=$P(DGPROC,U,I) Q:X=""  D
+ . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT))
+ . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
+ I $D(DGSURG) F I=2:1 S X=$P(DGSURG,U,I) Q:X=""  D
+ . S FLG=0,J=0 F  S J=$O(ICDPRC(J)) Q:'J  I X=$G(ICDPRC(J)) S FLG=1 Q
+ . I FLG Q
+ . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT))
+ . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X
+ ;
+ ;-- set other required variables
+ S ICDTRS=DGTRS,ICDEXP=DGEXP,ICDDMS=DGDMS
+ S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE  ;Ensure that DGDAT is defined prior to executing PRT
+ ;
+ ;-- calculate DRG
+ D ^ICDDRG S DRG=ICDDRG I '$D(DGDRGPRT) G Q
+ ;
+PRT ;print DRG and national HCFA values
+ I DRG=468!(DRG=469)!(DRG=470) W *7
+ S Y=ICDDATE D DD^%DT ; Y=external representation of effective date
+ W !!?9,"Effective Date:","  ",Y
+ S DRG(0)=$$DRG^ICDGTDRG(DRG,DGDAT) W !!,"Diagnosis Related Group: ",$J(DRG,6),?36,"Average Length of Stay(ALOS): ",$J($P(DRG(0),"^",8),6)
+ W !?17,"Weight: ",$J($P(DRG(0),"^",2),6)  ;,?40,"Local Breakeven: ",$J($P(DRG(0),"^",12),6)
+ W !?12," Low Day(s): ",$J($P(DRG(0),"^",3),6)  ;,?39,"Local Low Day(s): ",$J($P(DRG(0),"^",9),6)
+ W !?13," High Days: ",$J($P(DRG(0),"^",4),6)  ;,?40,"Local High Days: ",$J($P(DRG(0),"^",10),6)
+ N DXD,DGDX
+ S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DGDAT),DGI=0
+ W !!,"DRG: ",DRG,"-" F  S DGI=$O(DGDX(DGI)) Q:'+DGI  Q:DGDX(DGI)=" "  W ?10,DGDX(DGI),!
+Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS,ICDDATE Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTR1.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTR1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTR1.m	(revision 623)
@@ -1,77 +1,77 @@
-DGPTR1	;ALB/MTC - PTF VERIFICATION ; 12/14/06 10:31am
-	;;5.3;Registration;**58,247,338,342,423,415,565,678,696,729,781**;Aug 13, 1993;Build 1
-START	S T=$E(Y,2,3),T=$S(T=40&($E(Y,28)="P"):"P40",1:T),ERR=$P($T(@("T"_T)),";;",2,999),W=$P($T(@(T)),";;",2,999),F=31 D L
-	I T=70 S ERR=$P($T(T701),";;",2,999),W=$P($T(701),";;",2,999),F=72 D L
-	D @("D"_T) Q
-	K DGFILL
-	Q
-	;
-L	F H=1:1 S DGO=$P(W,U,H) Q:'DGO  F Z=1:1:$P(DGO,";",3) S DGL=$P(DGLOGIC,U,+DGO),X=$E(Y,F) D @("ERR:"_DGL) S F=F+1
-	Q
-	;
-T10	;;1:NAME^2:SOURCE OF ADM^3:TRANS FAC.^4:SOURCE OF PAY^5:POW^6:MARITAL ST^7:SEX^8:DOB^9:POS^10:VIETNAM^11:ION RADIATION^12:RESIDENCE^13:MEANS TEST^14:INCOME^15:MST^16:COMBAT VET^17:CV END DT^18:PROJ 112/SHAD^19:ERI
-	;
-T70	;;1:DT OF DISP.^2:DISCH BD SEC^3:TYPE OF DIS^4:OUT TREAT^5:VA AUS^6:PL OF DIS^7:REC FAC^8:ASIH DAYS^9:NOT USED^10:C&P STAT^11:PDXLS^12:ONLY DX^13:PHY MPCR
-	;T701 is part 2 of T70
-T701	;;1:PHY SPEC^2:%SC^3:LEGION^4:SUICIDE^5:DRUG^6:AXIS-IV^7:AXIS-V^8:SC^9:EXP^10:MST^11:HNC^12:ETHNICITY^13:RACE^14:COMBAT VET
-	;
-T50	;;1:DT OF MVMT^2:LOSING BD SEC MPCR^3:LOSING BD SEC^4:LEAVE DAYS^5:PASS DAYS^6:SCI^7:DIAG^8:DOCTOR'S SSN^9:PHY MPCR^10:PHY SPEC^11:DISCHARGE STAT^^^^^16:LEGION^17:SUICIDE^18:DRUG^19:AXIS-IV^20:AXIS-V^21:SC^22:EXP^23:MST^24:HNC
-	;
-T53	;;1:DATE OF PHYSICAL MOVEMENT^2:LOSING PHYSICAL MPCR^3:LOSING PHYSICAL SPECIALTY^4:TR SPECIALTY MPCR^5:TR SPECIALTY^6:LEAVE DAYS^7:PASS DAYS^8:DOCTOR'S SSN (NOT USED)
-	;
-T40	;;1:DATE OF SURGERY^2:SURG SPEC.^3:CAT CHIEF SURGEON^4:CAT FIRST ASS^5:ANEST. TECH.^6:SOURCE OF PAY^7:OP CODE^8:DOCTOR'S SSN (NOT USED)^^^^^13:TRANSPLANT STATUS
-	;
-TP40	;;1:OP CODE
-	;
-T60	;;1:DATE OF PROCEDURE^2:LOSING BD SEC^3:DIALYSIS TYPE^4:NUMBER OF TREATMENTS^5:PROCEDURE CODE
-	;
-LOGIC	;;X'?.N^X'?.A&(X'=" ")^X'=" "^X'?.N&(X'=" ")^X'?.A&(X'=" ")^0^X'?.N&(X'="X")^X'=" "&(X'="P")^X="E"^X="Y"^X=" "^X'="A"&(X'=" ")^(X'?.A)&(X'?.N)&(X'=" ")^(X'?.AN)&('$P(DG0,U,4))^((T1)&(X'=" "))!(('T1)&(X'?.AN)&('$P(DG0,U,4)))^(X'?.AN)
-	;
-	; ; edit check# ; edit field ; # x check preformed ; display error name #
-10	;;6;;12;1^2;1;1;1^5;1;1;1^1;2;1;2^2;2;1;2^4;3;3;3^6;;3;3^4;4;1;4^6;5;1;5^2;6;1;6^2;7;1;7^1;8;8;8^6;;1;9^11;9;1;9^4;10;1;10^4;10;1;11^1;11;5;12^7;11;5;12^2;12;1;13^6;;1;13^1;;6;14^2;;1;15^1;;1;16^4;;6;17^3;;1;18^5;;1;19^3;;29
-	;
-70	;;1;1;10;1^13;2;2;2^1;3;1;3^4;4;1;4^4;5;1;5^6;;1;6^4;7;3;7^6;;3;7^4;8;3;8^6;9;1;9^1;10;1;10^9;11;1;11^11;11;2;11^6;;3;11^10;11;1;11^6;;1;12^15;;6;13
-	;701 is part 2 of 70
-701	;;15;;2;1^1;;3;2^4;;1;3^4;;1;4^12;;1;5^4;;3;5^4;;1;6^4;;4;7^4;;1;8^5;;3;9^5;;1;10^5;;1;11^13;12;2;12^13;13;12;13^5;;1;14^3;;17
-	;
-50	;;1;1;10;1^1;;6;2^16;3;2;3^1;4;3;4^1;5;3;5^6;;1;6^11;7;3;7^6;;32;7^6;;9;8^14;;6;9^14;;2;10^6;;1;11^4;;1;16^4;;1;17^12;;1;18^4;;3;18^4;;1;19^4;;4;20^4;;1;21^5;;3;22^5;;1;23^5;;1;24
-	;
-53	;;1;;10;1^1;;6;2^13;;2;3^1;;6;4^13;;2;5^1;;3;6^1;;3;7^3;;9;8^3;;54;
-	;
-40	;;1;1;10;1^1;2;2;2^11;3;1;3^4;4;1;4^6;5;1;5^4;6;1;6^11;7;2;7^6;;3;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^3;;9;8^4;;1;13^3;;34;
-	;
-P40	;;8;;1;^3;;11;^11;1;2;1^6;;3;1^3;1;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^3;;48
-	;
-60	;;1;1;10;1^13;2;2;2^4;3;1;3^4;4;3;4^11;5;3;5^6;;32;5^3;;44
-	;
-ERR	S DGERR=1
-	W !,T,$S(T["H":" ",1:$E(Y,4)),"  "
-	W:"45"[$E(T,1) $E(Y,31,32),"-",$E(Y,33,34),"-",$E(Y,35,36),"@",$E(Y,37,40)
-	W ?25,$P($P(ERR,U,$P(DGO,";",4)),":",2),?40,"COL.",F,"  VALUE: ",$S($E(Y,F)=" ":"BLANK",1:$E(Y,F))
-	S I=$S('$D(I):1,I>0:I,1:1),^(I)=$S($D(^UTILITY("DG",$J,T_$S(T["H":"",1:$E(Y,4)),I)):^(I),1:U) I $P(DGO,";",2),^(I)'[(U_$P(DGO,";",2)_U) S ^(I)=^(I)_$P(DGO,";",2)_U
-	Q
-	;
-D10	I $E(Y,66)="Z" S (F,H)=68,W="11;10;1;10" D L
-	I $P(^DGPT(J,0),"^",4),$P(^(0),"^",10)="U",$D(^DGPT(J,70)),+^(70)>2890700 S F=79,DGO="2;12;1;12" D ERR
-	Q
-	;
-D40	Q
-DP40	Q
-D70	I "467"'[$E(Y,43) S F=44,W="4;4;1;4^1;5;1;5^11;6;1;6" D L
-	Q
-D50	I "A0"[$P(DG0,U,5)!("A4"[$P(DG0,U,5))!('$D(^DGPT(J,70))) S W="11;6;1;6",F=55 D L
-	I $D(^DGPT(J,70)),$S(T1:1,1:+^(70)>2871000) S W="11;6;1;6",F=55 D L
-	I $E(Y,4)=1 S W="9;7;1;7",F=56 D L
-	I I=1,'T1 S W="1;11;1;11",F=108 D L
-	Q
-D53	Q
-D60	I $E(Y,43) S F=44,W="1;4;3;4" D L
-	Q
-HEAD	S ERR="1:SSN^2:ADMISSION DATE^3:FACILITY #",W="8;1;1;1^1;1;9;1^1;2;10;2^1;3;3;3^6;;3;3",F=5,DGLOGIC=$P($T(LOGIC),";;",2),T="HEADER"
-	D L
-	Q
-LOG	S DGLOGIC=$P($T(LOGIC),";;",2)
-	Q
-CEN	S T=70,ERR=$P($T(T70),";;",2),W=$P($T(70),";;",2,999),W="13;9;1;9"_$P(W,"13;9;1;9",2,999),F=56 D L
-	S ERR=$P($T(T701),";;",2),W=$P($T(701),";;",2,999),F=72 D L
-	Q
+DGPTR1 ;ALB/MTC - PTF VERIFICATION ; 12/14/06 10:31am
+ ;;5.3;Registration;**58,247,338,342,423,415,565,678,696,729**;Aug 13, 1993;Build 59
+START S T=$E(Y,2,3),T=$S(T=40&($E(Y,28)="P"):"P40",1:T),ERR=$P($T(@("T"_T)),";;",2,999),W=$P($T(@(T)),";;",2,999),F=31 D L
+ I T=70 S ERR=$P($T(T701),";;",2,999),W=$P($T(701),";;",2,999),F=72 D L
+ D @("D"_T) Q
+ K DGFILL
+ Q
+ ;
+L F H=1:1 S DGO=$P(W,U,H) Q:'DGO  F Z=1:1:$P(DGO,";",3) S DGL=$P(DGLOGIC,U,+DGO),X=$E(Y,F) D @("ERR:"_DGL) S F=F+1
+ Q
+ ;
+T10 ;;1:NAME^2:SOURCE OF ADM^3:TRANS FAC.^4:SOURCE OF PAY^5:POW^6:MARITAL ST^7:SEX^8:DOB^9:POS^10:VIETNAM^11:ION RADIATION^12:RESIDENCE^13:MEANS TEST^14:INCOME^15:MST^16:COMBAT VET^17:CV END DT^18:PROJ 112/SHAD^19:ERI
+ ;
+T70 ;;1:DT OF DISP.^2:DISCH BD SEC^3:TYPE OF DIS^4:OUT TREAT^5:VA AUS^6:PL OF DIS^7:REC FAC^8:ASIH DAYS^9:NOT USED^10:C&P STAT^11:PDXLS^12:ONLY DX^13:PHY MPCR
+ ;T701 is part 2 of T70
+T701 ;;1:PHY SPEC^2:%SC^3:LEGION^4:SUICIDE^5:DRUG^6:AXIS-IV^7:AXIS-V^8:SC^9:EXP^10:MST^11:HNC^12:ETHNICITY^13:RACE^14:COMBAT VET
+ ;
+T50 ;;1:DT OF MVMT^2:LOSING BD SEC MPCR^3:LOSING BD SEC^4:LEAVE DAYS^5:PASS DAYS^6:SCI^7:DIAG^8:DOCTOR'S SSN^9:PHY MPCR^10:PHY SPEC^11:DISCHARGE STAT^^^^^16:LEGION^17:SUICIDE^18:DRUG^19:AXIS-IV^20:AXIS-V^21:SC^22:EXP^23:MST^24:HNC
+ ;
+T53 ;;1:DATE OF PHYSICAL MOVEMENT^2:LOSING PHYSICAL MPCR^3:LOSING PHYSICAL SPECIALTY^4:TR SPECIALTY MPCR^5:TR SPECIALTY^6:LEAVE DAYS^7:PASS DAYS^8:DOCTOR'S SSN (NOT USED)
+ ;
+T40 ;;1:DATE OF SURGERY^2:SURG SPEC.^3:CAT CHIEF SURGEON^4:CAT FIRST ASS^5:ANEST. TECH.^6:SOURCE OF PAY^7:OP CODE^8:DOCTOR'S SSN (NOT USED)^^^^^13:TRANSPLANT STATUS
+ ;
+TP40 ;;1:OP CODE
+ ;
+T60 ;;1:DATE OF PROCEDURE^2:LOSING BD SEC^3:DIALYSIS TYPE^4:NUMBER OF TREATMENTS^5:PROCEDURE CODE
+ ;
+LOGIC ;;X'?.N^X'?.A&(X'=" ")^X'=" "^X'?.N&(X'=" ")^X'?.A&(X'=" ")^0^X'?.N&(X'="X")^X'=" "&(X'="P")^X="E"^X="Y"^X=" "^X'="A"&(X'=" ")^(X'?.A)&(X'?.N)&(X'=" ")^(X'?.AN)&('$P(DG0,U,4))^((T1)&(X'=" "))!(('T1)&(X'?.AN)&('$P(DG0,U,4)))
+ ;
+ ; edit check# ; edit field ; # x check preformed ; display error name #
+10 ;;6;;12;1^2;1;1;1^5;1;1;1^1;2;1;2^2;2;1;2^4;3;3;3^6;;3;3^4;4;1;4^6;5;1;5^2;6;1;6^2;7;1;7^1;8;8;8^6;;1;9^11;9;1;9^4;10;1;10^4;10;1;11^1;11;5;12^7;11;5;12^2;12;1;13^6;;1;13^1;;6;14^2;;1;15^1;;1;16^4;;6;17^3;;1;18^5;;1;19^3;;29
+ ;
+70 ;;1;1;10;1^13;2;2;2^1;3;1;3^4;4;1;4^4;5;1;5^6;;1;6^4;7;3;7^6;;3;7^4;8;3;8^6;9;1;9^1;10;1;10^9;11;1;11^11;11;2;11^6;;3;11^10;11;1;11^6;;1;12^15;;6;13
+ ;701 is part 2 of 70
+701 ;;15;;2;1^1;;3;2^4;;1;3^4;;1;4^12;;1;5^4;;3;5^4;;1;6^4;;4;7^4;;1;8^5;;3;9^5;;1;10^5;;1;11^13;12;2;12^13;13;12;13^5;;1;14^3;;17
+ ;
+50 ;;1;1;10;1^1;;6;2^13;3;2;3^1;4;3;4^1;5;3;5^6;;1;6^11;7;3;7^6;;32;7^6;;9;8^14;;6;9^14;;2;10^6;;1;11^4;;1;16^4;;1;17^12;;1;18^4;;3;18^4;;1;19^4;;4;20^4;;1;21^5;;3;22^5;;1;23^5;;1;24
+ ;
+53 ;;1;;10;1^1;;6;2^13;;2;3^1;;6;4^13;;2;5^1;;3;6^1;;3;7^3;;9;8^3;;54;
+ ;
+40 ;;1;1;10;1^1;2;2;2^11;3;1;3^4;4;1;4^6;5;1;5^4;6;1;6^11;7;2;7^6;;3;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^6;;5;7^3;7;2;7^3;;9;8^4;;1;13^3;;34;
+ ;
+P40 ;;8;;1;^3;;11;^11;1;2;1^6;;3;1^3;1;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^6;;5;1^3;;2;1^3;;48
+ ;
+60 ;;1;1;10;1^13;2;2;2^4;3;1;3^4;4;3;4^11;5;3;5^6;;32;5^3;;44
+ ;
+ERR S DGERR=1
+ W !,T,$S(T["H":" ",1:$E(Y,4)),"  "
+ W:"45"[$E(T,1) $E(Y,31,32),"-",$E(Y,33,34),"-",$E(Y,35,36),"@",$E(Y,37,40)
+ W ?25,$P($P(ERR,U,$P(DGO,";",4)),":",2),?40,"COL.",F,"  VALUE: ",$S($E(Y,F)=" ":"BLANK",1:$E(Y,F))
+ S I=$S('$D(I):1,I>0:I,1:1),^(I)=$S($D(^UTILITY("DG",$J,T_$S(T["H":"",1:$E(Y,4)),I)):^(I),1:U) I $P(DGO,";",2),^(I)'[(U_$P(DGO,";",2)_U) S ^(I)=^(I)_$P(DGO,";",2)_U
+ Q
+ ;
+D10 I $E(Y,66)="Z" S (F,H)=68,W="11;10;1;10" D L
+ I $P(^DGPT(J,0),"^",4),$P(^(0),"^",10)="U",$D(^DGPT(J,70)),+^(70)>2890700 S F=79,DGO="2;12;1;12" D ERR
+ Q
+ ;
+D40 Q
+DP40 Q
+D70 I "467"'[$E(Y,43) S F=44,W="4;4;1;4^1;5;1;5^11;6;1;6" D L
+ Q
+D50 I "A0"[$P(DG0,U,5)!("A4"[$P(DG0,U,5))!('$D(^DGPT(J,70))) S W="11;6;1;6",F=55 D L
+ I $D(^DGPT(J,70)),$S(T1:1,1:+^(70)>2871000) S W="11;6;1;6",F=55 D L
+ I $E(Y,4)=1 S W="9;7;1;7",F=56 D L
+ I I=1,'T1 S W="1;11;1;11",F=108 D L
+ Q
+D53 Q
+D60 I $E(Y,43) S F=44,W="1;4;3;4" D L
+ Q
+HEAD S ERR="1:SSN^2:ADMISSION DATE^3:FACILITY #",W="8;1;1;1^1;1;9;1^1;2;10;2^1;3;3;3^6;;3;3",F=5,DGLOGIC=$P($T(LOGIC),";;",2),T="HEADER"
+ D L
+ Q
+LOG S DGLOGIC=$P($T(LOGIC),";;",2)
+ Q
+CEN S T=70,ERR=$P($T(T70),";;",2),W=$P($T(70),";;",2,999),W="13;9;1;9"_$P(W,"13;9;1;9",2,999),F=56 D L
+ S ERR=$P($T(T701),";;",2),W=$P($T(701),";;",2,999),F=72 D L
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m	(revision 623)
@@ -1,231 +1,231 @@
-DGREG	;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ;1/27/07  13:08
-	;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-START	;
-EN	D LO^DGUTL S DGCLPR=""
-	N DGDIV
-	S DGDIV=$$PRIM^VASITE
-	S:DGDIV %ZIS("B")=$P($G(^DG(40.8,+DGDIV,"DEV")),U,1)
-	I $P(^DG(43,1,0),U,39) S %ZIS="NQ",%ZIS("A")="Select 1010 printer: " D ^%ZIS Q:POP  S (DGIO(10),DGIO("PRF"),DGIO("RT"),DGIO("HS"))=ION,DGASKDEV="" I $E(IOST,1,2)'["P-" W !,$C(7),"Not a printer" G DGREG
-	K %ZIS("B")
-	I '$D(DGIO),$P(^DG(43,1,0),U,30) S %ZIS="N",IOP="HOME" D ^%ZIS I $D(IOS),IOS,$D(^%ZIS(1,+IOS,99)),$D(^%ZIS(1,+^(99),0)) S Y=$P(^(0),U,1) W !,"Using closest printer ",Y,! F I=10,"PRF","RT","HS" S DGIO(I)=Y
-A	D ENDREG($G(DFN))
-	;
-	; ** VOE change 1 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	; if not VA agency code, add DIC("DR") to default some identifiers and
-	; skip others also, improve readability
-	;
-	; before change:
-	; W !! S DIC=2,DIC(0)="ALEQM",DLAYGO=2 K DIC("S"),DIC("B") D ^DIC K DLAYGO G Q1:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) N Y D PAUSE^DG10 D BEGINREG(DFN) I DGNEW D NEW^DGRP
-	;
-	; after change:
-	W !!
-	N Y,DGREGY S DGREGY=1 D  I DGREGY<0 G Q1
-	. N DIC S DIC=2 ; Patient file
-	. S DIC(0)="ALEQM" ; ask, laygo, echo, question, and multi-index
-	. N DLAYGO S DLAYGO=2 ; override file access by user: allow laygo
-	. I $G(DUZ("AG"))'="V" D  ;adjust identifiers asked for VOE
-	. . S DIC("DR")=".02;.03;994;.301///N;391///VISTA OFFICE EHR;1901///N;.09"
-	. ;
-	. D ^DIC ; Select Patient
-	. ;
-	. I Y<0 S DGREGY=-1 Q
-	. K DIC("DR")
-	. S (DFN,DA)=+Y
-	. S DGNEW=$P(Y,"^",3) ; new patient?
-	. N Y D PAUSE^DG10 ; prompt user before continuing
-	. D BEGINREG(DFN) ; lock patient record
-	;
-	; ** end of VOE change 1 **
-	;
-	;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
-	S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1)
-	I DOD S Y=DOD,DGPME=0 D DIED^DGPMV I DGPME K DFN,DGRPOUT G A
-	;
-	D CIRN
-	;
-	; ** VOE change 2 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	I $G(DGNEW) D NEW^DGRP ; execute new patient DR string
-	;
-	; send CMOR query and display results only if VA agency code
-	;
-	; before change:
-	; I +$G(DGNEW) D
-	;
-	; after change:
-	I $G(DGNEW),$G(DUZ("AG"))="V" D
-	. ;
-	. ; end of change
-	. ;
-	. ; query CMOR for Patient Record Flag Assignments if NEW patient and
-	. ; display results.
-	. I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
-	;
-	; before change:
-	; D ROMQRY
-	;
-	; after change:
-	I $G(DUZ("AG"))="V" D ROMQRY
-	;
-	; ** end of VOE change 2 **
-	;
-	S (DGFC,CURR)=0
-	D:'$G(DGNEW) WARN S DA=DFN,DGFC="^1",VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
-	S %ZIS="N",IOP="HOME" D ^%ZIS S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) D ENDREG($G(DFN)) D HL7A08^VAFCDD01 K DFN,DGRPOUT G A
-	D HINQ^DG10
-	I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3
-	;
-	; ** VOE change 3 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	; send financial query only for VA agency code
-	;
-	; before change:
-	; D REG^IVMCQ($G(DFN))  ; send financial query
-	;
-	; after change:
-	I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN)) ; send financial query
-	;
-	; ** end of VOE change 3 **
-	;
-	G A1
-	;
-RT	I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3
-	Q
-	;
-A1	W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data" S %=1 D YN^DICN D  G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G Q:'$D(DA)
-	.I +$G(DGNEW) Q
-	.I $$ADD^DGADDUTL($G(DFN)) ;
-	G CH
-PR	W !!,"Is the patient currently being followed in a clinic for the same condition" S %=0 D YN^DICN G Q:%=-1
-	I '% W !?4,$C(7),"Enter 'Y' if the patient is being followed in clinic for condition for which",!?6,"registered, 'N' if not." G PR
-	S CURR=% G SEEN
-	;
-CK	S DGEDCN=1 D ^DGRPC
-CH	S X=$S('$D(^DPT(DFN,.36)):1,$P(^(.36),"^",1)']"":1,1:0),X1=$S('$D(^DPT(DFN,.32)):1,$P(^(.32),"^",3)']"":1,1:0) I 'X,'X1 G CH1
-CH1	S DA=DFN G PR:'$D(^DPT("ADA",1,DA)) W !!,"There is still an open disposition--register aborted.",$C(7),$C(7) G Q
-SEEN	W !!,"Is the patient to be examined in the medical center today" S %=1 D YN^DICN S SEEN=% G:%<0 Q I %'>0 W !!,"Enter 'Y' if the patient is to be examined today, 'N' if not.",$C(7) G SEEN
-ABIL	D ^DGREGG
-ENR	; next line appears to be dead code.  left commented just to test.  mli 4/28/94
-	;S DE=0 F I=0:0 S I=$O(^DPT(DA,"DE",I)) Q:'I  I $P(^(I,0),"^",3)'?7N Q  D PR:'DE S L=+$P($S($D(^SC(L,0)):^(0),1:""),"^",1)
-REG	S (DIE,DIC)="^DPT("_DFN_",""DIS"",",%DT="PTEX",%DT("A")="Registration login date/time: NOW// "
-	W !,%DT("A") R ANS:DTIME S:'$T ANS="^" S:ANS="" ANS="N" S X=ANS G Q:ANS="^" S DA(1)=DFN D CHK^DIE(2.101,.01,"E",X,.RESULT) G REG:RESULT="^"!('$D(RESULT)),PR3:'(RESULT#1) S Y=RESULT
-	I (RESULT'="^") W "  ("_RESULT(0)_")"
-	S DINUM=9999999-RESULT
-	S (DFN1,Y1)=DINUM,APD=Y I $D(^DPT(DFN,"DIS",Y1)) W !!,"You must enter a date that does not exist.",$C(7),$C(7) G REG
-	G:$D(^DPT("ADA",1,DA)) CH1 L @(DIE_DINUM_")"):2 G:'$T MSG S:'($D(^DPT(DA(1),"DIS",0))#2) ^(0)="^2.101D^^" S DIC(0)="L",X=+Y D ^DIC
-	;
-	;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT
-	S VAFCDDT=X
-	;
-	S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
-	;
-	; ** VOE change 4 of 4: DAOU/JLG 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	; for VOE or IHS agency codes, add the following:
-	; force TYPE OF CARE with ALL OTHER
-	;
-	I $G(DUZ("AG"))="E"!($G(DUZ("AG"))="I") D
-	. S DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1///5;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
-	;
-	; ** end of VOE change 4 **
-	;
-	D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:2 G:'$T MSG D ^DIE L -@DGNDLOCK
-	I $D(DTOUT) D  G Q
-	.K DTOUT
-	.N DA,DIK
-	.S DA(1)=DFN,DA=DFN1,DIK="^DPT("_DFN_",""DIS"","
-	.D ^DIK
-	.W !!?5,"User Time-out.  Required registration data could be missing."
-	.W !,?5,"This registration has been deleted."
-	; check whether facility applying to (division) is inactive
-	I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT
-ASKDIV	W !!?5,"The facility chosen either has no pointer to an Institution"
-	W !?5,"file record or the Institution file record is inactive."
-	W !?5,"Please choose another division."
-	S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^DIE
-	I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV
-CONT	; continue
-	S DGXXXD=1 D EL^DGREGE I $P(^DPT(DFN,"DIS",DFN1,0),"^",3)=4 S DA=DFN,DIE="^DPT(",DR=".368;.369" D ^DIE S DIE="^DPT("_DFN_",""DIS"",",DA(1)=DFN,DA=DFN1
-	S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^")
-	I $D(^DPT(DFN,"DIS",DFN1,2)),$P(^(2),"^",1)="Y" S DIE="^DPT(",DR="[DG EMPLOYER]",DA=DFN D ^DIE
-	G ^DGREG0
-PR2	W !!,"You can only enter new registrations through this option.",$C(7),$C(7) G REG
-PR3	W !!,"Time is required to register the patient.",!!,$C(7),$C(7) G REG
-H	W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue." G A1
-Q	K DG,DQ G Q1^DGREG0
-Q1	K DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW Q
-EL	S DR=DR_";13//" I $D(^DPT(DFN,.36)),$D(^DIC(8,+^(.36),0)) S DR=DR_$P(^(0),"^",1) Q
-	S DR=DR_"HUMANITARIAN EMERGENCY" Q
-FEE	S DGRPFEE=1 D DGREG K DGRPFEE G Q1
-	;
-WARN	I $S('$D(^DPT(DFN,.1)):0,$P(^(.1),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY AN INPATIENT***",! H 2
-	I $S('$D(^DPT(DFN,.107)):0,$P(^(.107),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY A LODGER***",! H 2
-	Q
-MSG	W !,"Another user is editing, try later ..." G Q
-	;
-BEGINREG(DFN)	;
-	;Description: This is called at the beginning of the registration process.
-	;Concurrent processes can check the lock to determine if the patient is
-	;currently being registered.
-	;
-	Q:'$G(DFN) 0
-	I $$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!!
-	L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
-	I $$LOCK^DGENPTA1(DFN) ;try to lock the patient record
-	Q
-	;
-ENDREG(DFN)	;
-	;Description: releases the lock obtained by calling BEGINREG.
-	;
-	Q:'$G(DFN)
-	L -^TMP(DFN,"REGISTRATION IN PROGRESS")
-	D UNLOCK^DGENPTA1(DFN)
-	Q
-	;
-IFREG(DFN)	;
-	;Description: tests whether the lock set by BEGINREG is set
-	;
-	;Input:  DFN
-	;Output:
-	;      Function Value = 1 if lock is set, 0 otherwise
-	;
-	N RETURN
-	Q:'$G(DFN) 0
-	L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
-	S RETURN='$T
-	L -^TMP(DFN,"REGISTRATION IN PROGRESS")
-	Q RETURN
-	Q
-CIRN	;MPI QUERY
-	;check to see if CIRN PD/MPI is installed
-	N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T
-	K MPIFRTN
-	D MPIQ^MPIFAPI(DFN)
-	K MPIFRTN
-	Q
-ROMQRY	;
-	I +$G(DGNEW) D
-	. ; query LST for Patient Demographic Information if NEW patient and
-	. ; file into patient's record.
-	. N A
-	. I $$ROMQRY^DGROAPI(DFN) D
-	. . ;display busy message to interactive users
-	. .S DGMSG(1)="Data retrieval from LST site has been completed successfully"
-	. .S DGMSG(2)="Thank you for your patience."
-	. .D EN^DDIOL(.DGMSG) R A:5
-	. E  D
-	. . ;display busy message to interactive users
-	. .S DGMSG(1)="Data retrieval from LST site has not been successful."
-	. .S DGMSG(2)="Please continue the Registration Process."
-	. .D EN^DDIOL(.DGMSG) R A:5
-	. ;
-	Q
+DGREG ;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ;1/27/07  13:08
+ ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+START ;
+EN D LO^DGUTL S DGCLPR=""
+ N DGDIV
+ S DGDIV=$$PRIM^VASITE
+ S:DGDIV %ZIS("B")=$P($G(^DG(40.8,+DGDIV,"DEV")),U,1)
+ I $P(^DG(43,1,0),U,39) S %ZIS="NQ",%ZIS("A")="Select 1010 printer: " D ^%ZIS Q:POP  S (DGIO(10),DGIO("PRF"),DGIO("RT"),DGIO("HS"))=ION,DGASKDEV="" I $E(IOST,1,2)'["P-" W !,$C(7),"Not a printer" G DGREG
+ K %ZIS("B")
+ I '$D(DGIO),$P(^DG(43,1,0),U,30) S %ZIS="N",IOP="HOME" D ^%ZIS I $D(IOS),IOS,$D(^%ZIS(1,+IOS,99)),$D(^%ZIS(1,+^(99),0)) S Y=$P(^(0),U,1) W !,"Using closest printer ",Y,! F I=10,"PRF","RT","HS" S DGIO(I)=Y
+A D ENDREG($G(DFN))
+ ;
+ ; ** VOE change 1 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; if not VA agency code, add DIC("DR") to default some identifiers and
+ ; skip others also, improve readability
+ ;
+ ; before change:
+ ; W !! S DIC=2,DIC(0)="ALEQM",DLAYGO=2 K DIC("S"),DIC("B") D ^DIC K DLAYGO G Q1:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) N Y D PAUSE^DG10 D BEGINREG(DFN) I DGNEW D NEW^DGRP
+ ;
+ ; after change:
+ W !!
+ N Y,DGREGY S DGREGY=1 D  I DGREGY<0 G Q1
+ . N DIC S DIC=2 ; Patient file
+ . S DIC(0)="ALEQM" ; ask, laygo, echo, question, and multi-index
+ . N DLAYGO S DLAYGO=2 ; override file access by user: allow laygo
+ . I $G(DUZ("AG"))'="V" D  ;adjust identifiers asked for VOE
+ . . S DIC("DR")=".02;.03;994;.301///N;391///VISTA OFFICE EHR;1901///N;.09"
+ . ;
+ . D ^DIC ; Select Patient
+ . ;
+ . I Y<0 S DGREGY=-1 Q
+ . K DIC("DR")
+ . S (DFN,DA)=+Y
+ . S DGNEW=$P(Y,"^",3) ; new patient?
+ . N Y D PAUSE^DG10 ; prompt user before continuing
+ . D BEGINREG(DFN) ; lock patient record
+ ;
+ ; ** end of VOE change 1 **
+ ;
+ ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
+ S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1)
+ I DOD S Y=DOD,DGPME=0 D DIED^DGPMV I DGPME K DFN,DGRPOUT G A
+ ;
+ D CIRN
+ ;
+ ; ** VOE change 2 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ I $G(DGNEW) D NEW^DGRP ; execute new patient DR string
+ ;
+ ; send CMOR query and display results only if VA agency code
+ ;
+ ; before change:
+ ; I +$G(DGNEW) D
+ ;
+ ; after change:
+ I $G(DGNEW),$G(DUZ("AG"))="V" D
+ . ;
+ . ; end of change
+ . ;
+ . ; query CMOR for Patient Record Flag Assignments if NEW patient and
+ . ; display results.
+ . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
+ ;
+ ; before change:
+ ; D ROMQRY
+ ;
+ ; after change:
+ I $G(DUZ("AG"))="V" D ROMQRY
+ ;
+ ; ** end of VOE change 2 **
+ ;
+ S (DGFC,CURR)=0
+ D:'$G(DGNEW) WARN S DA=DFN,DGFC="^1",VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
+ S %ZIS="N",IOP="HOME" D ^%ZIS S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) D ENDREG($G(DFN)) D HL7A08^VAFCDD01 K DFN,DGRPOUT G A
+ D HINQ^DG10
+ I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3
+ ;
+ ; ** VOE change 3 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; send financial query only for VA agency code
+ ;
+ ; before change:
+ ; D REG^IVMCQ($G(DFN))  ; send financial query
+ ;
+ ; after change:
+ I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN)) ; send financial query
+ ;
+ ; ** end of VOE change 3 **
+ ;
+ G A1
+ ;
+RT I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3
+ Q
+ ;
+A1 W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data" S %=1 D YN^DICN D  G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G Q:'$D(DA)
+ .I +$G(DGNEW) Q
+ .I $$ADD^DGADDUTL($G(DFN)) ;
+ G CH
+PR W !!,"Is the patient currently being followed in a clinic for the same condition" S %=0 D YN^DICN G Q:%=-1
+ I '% W !?4,$C(7),"Enter 'Y' if the patient is being followed in clinic for condition for which",!?6,"registered, 'N' if not." G PR
+ S CURR=% G SEEN
+ ;
+CK S DGEDCN=1 D ^DGRPC
+CH S X=$S('$D(^DPT(DFN,.36)):1,$P(^(.36),"^",1)']"":1,1:0),X1=$S('$D(^DPT(DFN,.32)):1,$P(^(.32),"^",3)']"":1,1:0) I 'X,'X1 G CH1
+CH1 S DA=DFN G PR:'$D(^DPT("ADA",1,DA)) W !!,"There is still an open disposition--register aborted.",$C(7),$C(7) G Q
+SEEN W !!,"Is the patient to be examined in the medical center today" S %=1 D YN^DICN S SEEN=% G:%<0 Q I %'>0 W !!,"Enter 'Y' if the patient is to be examined today, 'N' if not.",$C(7) G SEEN
+ABIL D ^DGREGG
+ENR ; next line appears to be dead code.  left commented just to test.  mli 4/28/94
+ ;S DE=0 F I=0:0 S I=$O(^DPT(DA,"DE",I)) Q:'I  I $P(^(I,0),"^",3)'?7N Q  D PR:'DE S L=+$P($S($D(^SC(L,0)):^(0),1:""),"^",1)
+REG S (DIE,DIC)="^DPT("_DFN_",""DIS"",",%DT="PTEX",%DT("A")="Registration login date/time: NOW// "
+ W !,%DT("A") R ANS:DTIME S:'$T ANS="^" S:ANS="" ANS="N" S X=ANS G Q:ANS="^" S DA(1)=DFN D CHK^DIE(2.101,.01,"E",X,.RESULT) G REG:RESULT="^"!('$D(RESULT)),PR3:'(RESULT#1) S Y=RESULT
+ I (RESULT'="^") W "  ("_RESULT(0)_")"
+ S DINUM=9999999-RESULT
+ S (DFN1,Y1)=DINUM,APD=Y I $D(^DPT(DFN,"DIS",Y1)) W !!,"You must enter a date that does not exist.",$C(7),$C(7) G REG
+ G:$D(^DPT("ADA",1,DA)) CH1 L @(DIE_DINUM_")"):2 G:'$T MSG S:'($D(^DPT(DA(1),"DIS",0))#2) ^(0)="^2.101D^^" S DIC(0)="L",X=+Y D ^DIC
+ ;
+ ;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT
+ S VAFCDDT=X
+ ;
+ S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
+ ;
+ ; ** VOE change 4 of 4: DAOU/JLG 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; for VOE or IHS agency codes, add the following:
+ ; force TYPE OF CARE with ALL OTHER
+ ;
+ I $G(DUZ("AG"))="E"!($G(DUZ("AG"))="I") D
+ . S DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1///5;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
+ ;
+ ; ** end of VOE change 4 **
+ ;
+ D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:2 G:'$T MSG D ^DIE L -@DGNDLOCK
+ I $D(DTOUT) D  G Q
+ .K DTOUT
+ .N DA,DIK
+ .S DA(1)=DFN,DA=DFN1,DIK="^DPT("_DFN_",""DIS"","
+ .D ^DIK
+ .W !!?5,"User Time-out.  Required registration data could be missing."
+ .W !,?5,"This registration has been deleted."
+ ; check whether facility applying to (division) is inactive
+ I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT
+ASKDIV W !!?5,"The facility chosen either has no pointer to an Institution"
+ W !?5,"file record or the Institution file record is inactive."
+ W !?5,"Please choose another division."
+ S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^DIE
+ I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV
+CONT ; continue
+ S DGXXXD=1 D EL^DGREGE I $P(^DPT(DFN,"DIS",DFN1,0),"^",3)=4 S DA=DFN,DIE="^DPT(",DR=".368;.369" D ^DIE S DIE="^DPT("_DFN_",""DIS"",",DA(1)=DFN,DA=DFN1
+ S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^")
+ I $D(^DPT(DFN,"DIS",DFN1,2)),$P(^(2),"^",1)="Y" S DIE="^DPT(",DR="[DG EMPLOYER]",DA=DFN D ^DIE
+ G ^DGREG0
+PR2 W !!,"You can only enter new registrations through this option.",$C(7),$C(7) G REG
+PR3 W !!,"Time is required to register the patient.",!!,$C(7),$C(7) G REG
+H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue." G A1
+Q K DG,DQ G Q1^DGREG0
+Q1 K DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW Q
+EL S DR=DR_";13//" I $D(^DPT(DFN,.36)),$D(^DIC(8,+^(.36),0)) S DR=DR_$P(^(0),"^",1) Q
+ S DR=DR_"HUMANITARIAN EMERGENCY" Q
+FEE S DGRPFEE=1 D DGREG K DGRPFEE G Q1
+ ;
+WARN I $S('$D(^DPT(DFN,.1)):0,$P(^(.1),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY AN INPATIENT***",! H 2
+ I $S('$D(^DPT(DFN,.107)):0,$P(^(.107),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY A LODGER***",! H 2
+ Q
+MSG W !,"Another user is editing, try later ..." G Q
+ ;
+BEGINREG(DFN) ;
+ ;Description: This is called at the beginning of the registration process.
+ ;Concurrent processes can check the lock to determine if the patient is
+ ;currently being registered.
+ ;
+ Q:'$G(DFN) 0
+ I $$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!!
+ L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
+ I $$LOCK^DGENPTA1(DFN) ;try to lock the patient record
+ Q
+ ;
+ENDREG(DFN) ;
+ ;Description: releases the lock obtained by calling BEGINREG.
+ ;
+ Q:'$G(DFN)
+ L -^TMP(DFN,"REGISTRATION IN PROGRESS")
+ D UNLOCK^DGENPTA1(DFN)
+ Q
+ ;
+IFREG(DFN) ;
+ ;Description: tests whether the lock set by BEGINREG is set
+ ;
+ ;Input:  DFN
+ ;Output:
+ ;      Function Value = 1 if lock is set, 0 otherwise
+ ;
+ N RETURN
+ Q:'$G(DFN) 0
+ L +^TMP(DFN,"REGISTRATION IN PROGRESS"):1
+ S RETURN='$T
+ L -^TMP(DFN,"REGISTRATION IN PROGRESS")
+ Q RETURN
+ Q
+CIRN ;MPI QUERY
+ ;check to see if CIRN PD/MPI is installed
+ N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T
+ K MPIFRTN
+ D MPIQ^MPIFAPI(DFN)
+ K MPIFRTN
+ Q
+ROMQRY ;
+ I +$G(DGNEW) D
+ . ; query LST for Patient Demographic Information if NEW patient and
+ . ; file into patient's record.
+ . N A
+ . I $$ROMQRY^DGROAPI(DFN) D
+ . . ;display busy message to interactive users
+ . .S DGMSG(1)="Data retrieval from LST site has been completed successfully"
+ . .S DGMSG(2)="Thank you for your patience."
+ . .D EN^DDIOL(.DGMSG) R A:5
+ . E  D
+ . . ;display busy message to interactive users
+ . .S DGMSG(1)="Data retrieval from LST site has not been successful."
+ . .S DGMSG(2)="Please continue the Registration Process."
+ . .D EN^DDIOL(.DGMSG) R A:5
+ . ;
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAED.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAED.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAED.m	(revision 623)
@@ -1,183 +1,183 @@
-DGREGAED	;ALB/DW/PHH - Address Edit API; 1/5/2006  23:03 ;10/10/06  08:05
-	;;5.3;Registration;**522,560,658,730,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-EN(DFN,FLG)	;Entry point
-	;Input: 
-	;  DFN (required) - Internal Entry # of Patient File (#2)
-	;  FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
-	;    FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
-	;    FLG(2) - if 1, display before & after address for user confirmation
-	K EASZIPLK
-	N DGINPUT
-	N I,X,Y
-	I $G(DFN)="" Q
-	I ($G(DFN)'?.N) Q
-	S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2))
-	D INPUT(.DGINPUT,DFN)
-	I $G(DGINPUT)=-1 Q
-	I $G(FLG(2))=1 D COMPARE(.DGINPUT,DFN)
-	I '$$CONFIRM() W !,"Change aborted." D EOP Q
-	N DGPRIOR
-	D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
-	D SAVE(.DGINPUT,DFN)
-	I +$G(DGNEW) Q
-	Q:'$$FILEYN^DGADDUTL(.DGPRIOR,.DGINPUT)
-	D GETUPDTS^DGADDUTL(DFN,.DGINPUT)
-	D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGINPUT)
-	Q
-INPUT(DGINPUT,DFN)	;Let user input address changes
-	;Output: DGINPUT(field#)=external^internal(if any)
-	N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,POP
-	S POP=0
-	;
-	; ** VOE change 1 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	; .134 is new field ALTERNATE PHONE for VOE
-	;
-	; before change:
-	;
-	; F DGN=.111,.112,.113,.1112,.131,.132,.121 Q:POP  D
-	;
-	; after change:
-	;
-	F DGN=.111,.112,.113,.1112,.131,.132,.134,.121 Q:POP  D
-	. ;
-	. ; end change
-	. ;
-	. I ($G(DGINPUT(.111))="")&((DGN=.112)!(DGN=.113)) Q
-	. I ($G(DGINPUT(.112))="")&(DGN=.113) Q
-	. I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) Q
-	. I DGN=.1112 D  Q
-	.. D EN^DGREGAZL(.DGR,DFN)
-	.. I $G(DGR)=-1 S POP=1 Q
-	.. N DGM F DGM=.1112,.114,.115,.117 S DGINPUT(DGM)=$G(DGR(DGM))
-	. ;
-	. ; new line:
-	. ;
-	. I DGN=.134,$G(DUZ("AG"))'="E" Q
-	. ;
-	. ; ** end of VOE change 1 **
-	. ;
-AGN	. S DIR(0)=2_","_DGN
-	. S DA=DFN
-	. D ^DIR
-	. I $D(DTOUT) S POP=1 Q
-	. I $D(DUOUT)!$D(DIROUT) D UPCT G AGN
-	. I DGN'=.121 S DGINPUT(DGN)=$G(Y)
-	. I DGN=.121 D
-	.. I $P($G(Y),U)=$$GET1^DIQ(2,DFN_",",DGN,"I") D
-	... S DGINPUT(DGN)=$$GET1^DIQ(2,DFN_",",DGN)_U_$P($G(Y),U)
-	.. I $P($G(Y),U)'=$$GET1^DIQ(2,DFN_",",DGN,"I") D
-	... S DGINPUT(DGN)=$P($G(Y(0)),U)_U_$G(Y)
-	I $G(POP)=1 S DGINPUT=-1
-	Q
-COMPARE(DGINPUT,DFN)	;Display before & after address fields.
-	N DGCURR,DGN,DGCMP,DGM,DGCNTY,DGCIEN,DGST
-	D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121","EI","DGCURR")
-	;
-	; ** VOE change 2 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
-	;
-	; for VOE agency code, add new ALTERNATE PHONE field (.134)
-	; to DGCMP("OLD") array
-	;
-	; before change:
-	;
-	; F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121 D
-	; . S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
-	;
-	; after change:
-	;
-	I $G(DUZ("AG"))="E" D GETS^DIQ(2,DFN,.134,"EI","DGCURR")
-	F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.134,.121 D
-	. I $G(DUZ("AG"))'="E",DGN=.134 Q  ; skip for non-VOE
-	. ;
-	. ; ** end of VOE change 2 **
-	. ;
-	. S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
-	S DGCIEN=$G(DGCURR(2,DFN_",",.117,"I"))
-	S DGST=$G(DGCURR(2,DFN_",",.115,"I"))
-	S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
-	I DGCNTY=-1 S DGCNTY=""
-	S DGCMP("OLD",.117)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3)
-	M DGCMP("NEW")=DGINPUT
-	S DGCNTY=$P($G(DGCMP("NEW",.117)),U)_" "_$P($G(DGCMP("NEW",.117)),U,3)
-	S DGCMP("NEW",.117)=DGCNTY
-	I ($L(DGCMP("NEW",.1112))>5)&($P(DGCMP("NEW",.1112),"-",2)="") S DGCMP("NEW",.1112)=$E(DGCMP("NEW",.1112),1,5)_"-"_$E(DGCMP("NEW",.1112),6,9)
-	F DGM="OLD","NEW" D
-	. W !,?2,"[",DGM," ADDRESS]"
-	. W ?16,$P($G(DGCMP(DGM,.111)),U)
-	. I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U)
-	. I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U)
-	. W !,?16,$P($G(DGCMP(DGM,.114)),U)
-	. W:($P($G(DGCMP(DGM,.114)),U)'="")!($P($G(DGCMP(DGM,.115)),U)'="") ","
-	. W $P($G(DGCMP(DGM,.115)),U)
-	. W " ",$G(DGCMP(DGM,.1112))
-	. I $P($G(DGCMP(DGM,.117)),U)'="" W !,?6,"  County: ",$P($G(DGCMP(DGM,.117)),U)
-	. I $G(FLG(1))=1 D
-	.. W !,?6,"   Phone: ",?16,$P($G(DGCMP(DGM,.131)),U)
-	.. W !,?6,"  Office: ",?16,$P($G(DGCMP(DGM,.132)),U)
-	.. ;
-	.. ; ** VOE change 3 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
-	.. ;
-	.. ; for VOE agency code, display new ALTERNATE PHONE field (.134)
-	.. ;
-	.. ; insert line:
-	.. ;
-	.. I $G(DUZ("AG"))="E" W !,?6," Alt Phone: ",?16,$P($G(DGCMP(DGM,.134)),U)
-	.. ;
-	.. ; ** end of VOE change 3 **
-	.. ;
-	. W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U)
-	. W !
-	Q
-CONFIRM()	;Confirm if user wants to save the change
-	N DIR,X,Y,DTOUT,DUOUT,DIROUT
-	S DIR(0)="Y"
-	S DIR("A")="Are you sure that you want to save the above changes"
-	S DIR("?")="Please answer Y for YES or N for NO."
-	D ^DIR
-	I $D(DTOUT)!($G(Y)=0) Q 0
-	I $D(DUOUT)!$D(DIROUT) Q 0
-	Q 1
-SAVE(DGINPUT,DFN)	;Save changes
-	N DGN,DGER,DGM
-	S DGER=0
-	F DGN=.111,.112,.113,.131,.132,.1112,.114,.115,.117,.121 D
-	. I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) Q
-	. N DGCODE,DGNAME,FDA,MSG
-	. S DGCODE=$P($G(DGINPUT(DGN)),U,2)
-	. S DGNAME=$P($G(DGINPUT(DGN)),U)
-	. S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME)
-	. D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG")
-	. I $D(MSG) D
-	.. S DGM="",DGER=1
-	.. W !,"Please review the saved changes!!",!
-	.. F  S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM=""  D
-	... W $G(MSG("DIERR",1,"TEXT",DGM))
-	I $G(DGER)=0 W !,"Change saved."
-	D EOP
-	Q
-EOP	;End of page prompt
-	N DIR,DTOUT,DUOUT,DIROUT,X,Y
-	S DIR(0)="E"
-	S DIR("A")="Press ENTER to continue"
-	D ^DIR
-	Q
-UPCT	;Indicate "^" or "^^" are unacceptable inputs.
-	W !,"EXIT NOT ALLOWED ??"
-	Q
+DGREGAED ;ALB/DW/PHH - Address Edit API; 1/5/2006  23:03 ;10/10/06  08:05
+ ;;5.3;Registration;**522,560,658,730,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+EN(DFN,FLG) ;Entry point
+ ;Input: 
+ ;  DFN (required) - Internal Entry # of Patient File (#2)
+ ;  FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
+ ;    FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
+ ;    FLG(2) - if 1, display before & after address for user confirmation
+ K EASZIPLK
+ N DGINPUT
+ N I,X,Y
+ I $G(DFN)="" Q
+ I ($G(DFN)'?.N) Q
+ S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2))
+ D INPUT(.DGINPUT,DFN)
+ I $G(DGINPUT)=-1 Q
+ I $G(FLG(2))=1 D COMPARE(.DGINPUT,DFN)
+ I '$$CONFIRM() W !,"Change aborted." D EOP Q
+ N DGPRIOR
+ D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
+ D SAVE(.DGINPUT,DFN)
+ I +$G(DGNEW) Q
+ Q:'$$FILEYN^DGADDUTL(.DGPRIOR,.DGINPUT)
+ D GETUPDTS^DGADDUTL(DFN,.DGINPUT)
+ D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGINPUT)
+ Q
+INPUT(DGINPUT,DFN) ;Let user input address changes
+ ;Output: DGINPUT(field#)=external^internal(if any)
+ N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,POP
+ S POP=0
+ ;
+ ; ** VOE change 1 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; .134 is new field ALTERNATE PHONE for VOE
+ ;
+ ; before change:
+ ;
+ ; F DGN=.111,.112,.113,.1112,.131,.132,.121 Q:POP  D
+ ;
+ ; after change:
+ ;
+ F DGN=.111,.112,.113,.1112,.131,.132,.134,.121 Q:POP  D
+ . ;
+ . ; end change
+ . ;
+ . I ($G(DGINPUT(.111))="")&((DGN=.112)!(DGN=.113)) Q
+ . I ($G(DGINPUT(.112))="")&(DGN=.113) Q
+ . I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) Q
+ . I DGN=.1112 D  Q
+ .. D EN^DGREGAZL(.DGR,DFN)
+ .. I $G(DGR)=-1 S POP=1 Q
+ .. N DGM F DGM=.1112,.114,.115,.117 S DGINPUT(DGM)=$G(DGR(DGM))
+ . ;
+ . ; new line:
+ . ;
+ . I DGN=.134,$G(DUZ("AG"))'="E" Q
+ . ;
+ . ; ** end of VOE change 1 **
+ . ;
+AGN . S DIR(0)=2_","_DGN
+ . S DA=DFN
+ . D ^DIR
+ . I $D(DTOUT) S POP=1 Q
+ . I $D(DUOUT)!$D(DIROUT) D UPCT G AGN
+ . I DGN'=.121 S DGINPUT(DGN)=$G(Y)
+ . I DGN=.121 D
+ .. I $P($G(Y),U)=$$GET1^DIQ(2,DFN_",",DGN,"I") D
+ ... S DGINPUT(DGN)=$$GET1^DIQ(2,DFN_",",DGN)_U_$P($G(Y),U)
+ .. I $P($G(Y),U)'=$$GET1^DIQ(2,DFN_",",DGN,"I") D
+ ... S DGINPUT(DGN)=$P($G(Y(0)),U)_U_$G(Y)
+ I $G(POP)=1 S DGINPUT=-1
+ Q
+COMPARE(DGINPUT,DFN) ;Display before & after address fields.
+ N DGCURR,DGN,DGCMP,DGM,DGCNTY,DGCIEN,DGST
+ D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121","EI","DGCURR")
+ ;
+ ; ** VOE change 2 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; for VOE agency code, add new ALTERNATE PHONE field (.134)
+ ; to DGCMP("OLD") array
+ ;
+ ; before change:
+ ;
+ ; F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121 D
+ ; . S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
+ ;
+ ; after change:
+ ;
+ I $G(DUZ("AG"))="E" D GETS^DIQ(2,DFN,.134,"EI","DGCURR")
+ F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.134,.121 D
+ . I $G(DUZ("AG"))'="E",DGN=.134 Q  ; skip for non-VOE
+ . ;
+ . ; ** end of VOE change 2 **
+ . ;
+ . S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
+ S DGCIEN=$G(DGCURR(2,DFN_",",.117,"I"))
+ S DGST=$G(DGCURR(2,DFN_",",.115,"I"))
+ S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN)
+ I DGCNTY=-1 S DGCNTY=""
+ S DGCMP("OLD",.117)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3)
+ M DGCMP("NEW")=DGINPUT
+ S DGCNTY=$P($G(DGCMP("NEW",.117)),U)_" "_$P($G(DGCMP("NEW",.117)),U,3)
+ S DGCMP("NEW",.117)=DGCNTY
+ I ($L(DGCMP("NEW",.1112))>5)&($P(DGCMP("NEW",.1112),"-",2)="") S DGCMP("NEW",.1112)=$E(DGCMP("NEW",.1112),1,5)_"-"_$E(DGCMP("NEW",.1112),6,9)
+ F DGM="OLD","NEW" D
+ . W !,?2,"[",DGM," ADDRESS]"
+ . W ?16,$P($G(DGCMP(DGM,.111)),U)
+ . I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U)
+ . I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U)
+ . W !,?16,$P($G(DGCMP(DGM,.114)),U)
+ . W:($P($G(DGCMP(DGM,.114)),U)'="")!($P($G(DGCMP(DGM,.115)),U)'="") ","
+ . W $P($G(DGCMP(DGM,.115)),U)
+ . W " ",$G(DGCMP(DGM,.1112))
+ . I $P($G(DGCMP(DGM,.117)),U)'="" W !,?6,"  County: ",$P($G(DGCMP(DGM,.117)),U)
+ . I $G(FLG(1))=1 D
+ .. W !,?6,"   Phone: ",?16,$P($G(DGCMP(DGM,.131)),U)
+ .. W !,?6,"  Office: ",?16,$P($G(DGCMP(DGM,.132)),U)
+ .. ;
+ .. ; ** VOE change 3 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ .. ;
+ .. ; for VOE agency code, display new ALTERNATE PHONE field (.134)
+ .. ;
+ .. ; insert line:
+ .. ;
+ .. I $G(DUZ("AG"))="E" W !,?6," Alt Phone: ",?16,$P($G(DGCMP(DGM,.134)),U)
+ .. ;
+ .. ; ** end of VOE change 3 **
+ .. ;
+ . W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U)
+ . W !
+ Q
+CONFIRM() ;Confirm if user wants to save the change
+ N DIR,X,Y,DTOUT,DUOUT,DIROUT
+ S DIR(0)="Y"
+ S DIR("A")="Are you sure that you want to save the above changes"
+ S DIR("?")="Please answer Y for YES or N for NO."
+ D ^DIR
+ I $D(DTOUT)!($G(Y)=0) Q 0
+ I $D(DUOUT)!$D(DIROUT) Q 0
+ Q 1
+SAVE(DGINPUT,DFN) ;Save changes
+ N DGN,DGER,DGM
+ S DGER=0
+ F DGN=.111,.112,.113,.131,.132,.1112,.114,.115,.117,.121 D
+ . I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) Q
+ . N DGCODE,DGNAME,FDA,MSG
+ . S DGCODE=$P($G(DGINPUT(DGN)),U,2)
+ . S DGNAME=$P($G(DGINPUT(DGN)),U)
+ . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME)
+ . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG")
+ . I $D(MSG) D
+ .. S DGM="",DGER=1
+ .. W !,"Please review the saved changes!!",!
+ .. F  S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM=""  D
+ ... W $G(MSG("DIERR",1,"TEXT",DGM))
+ I $G(DGER)=0 W !,"Change saved."
+ D EOP
+ Q
+EOP ;End of page prompt
+ N DIR,DTOUT,DUOUT,DIROUT,X,Y
+ S DIR(0)="E"
+ S DIR("A")="Press ENTER to continue"
+ D ^DIR
+ Q
+UPCT ;Indicate "^" or "^^" are unacceptable inputs.
+ W !,"EXIT NOT ALLOWED ??"
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAZL.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAZL.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAZL.m	(revision 623)
@@ -1,192 +1,184 @@
-DGREGAZL	;ALB/DW - ZIP LINKING UTILITY ; 5/27/04 10:54am
-	;;5.3;Registration;**522,560,581,730,760**;Aug 13, 1993;Build 11
-	;
-EN(RESULT,DFN)	;Let user edit zip+4, city, state, county based on zip-linking
-	; Output: RESULT(field#) = User Input External ^ Internal
-	K RESULT
-	N DGIND,DGTOT
-	I $G(DFN)="" S RESULT=-1 Q
-	N DGR,DGDFLT,DGALW,DGZIP,DGN
-	S DGN=""
-	I $$FOREIGN() D  Q
-	. D FRGNEDT(.DGR,DFN)
-	. I $G(DGR)=-1 S RESULT=-1 Q
-	. F DGN=.1112,.114,.115,.117 S RESULT(DGN)=$G(DGR(DGN))
-	S DGZIP=$$ZIP(DFN)
-	I DGZIP=-1 S RESULT=-1 Q
-	S RESULT(.1112)=DGZIP
-	S DGIND=$$CITY(.DGR,DGZIP,DFN)
-	I DGIND=$G(DGTOT)+1 S DGIND=""
-	I $G(DGR)=-1 S RESULT=-1 Q
-	S RESULT(.114)=$G(DGR)
-	S DGALW=$$ALWEDT^DGREGDD1($G(DUZ),DGZIP)
-	I DGALW=1 D
-	. K DGR D STCNTY(.DGR,DGZIP,DFN,DGIND)
-	. I $G(DGR)=-1 S RESULT=-1 Q
-	. S RESULT(.115)=$G(DGR(.115))
-	. S RESULT(.117)=$G(DGR(.117))
-	I DGALW=0 D
-	. I DGZIP'="" D LINK(.DGDFLT,DGZIP,1)
-	. S RESULT(.115)=$G(DGDFLT(.115))
-	. S RESULT(.117)=$G(DGDFLT(.117))
-	Q
-ZIP(DFN)	;Let user input zip+4
-ZAGN	N DIR,DTOUT,DUOUT,DIROUT,DGDATA
-	S DIR(0)="2,.1112"
-	S DA=DFN
-	D ^DIR
-	I $D(DTOUT) Q -1
-	I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G ZAGN
-	S DGZIP=$G(Y)
-	;allow bogus zip:
-	I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q DGZIP
-	I DGZIP="" Q DGZIP
-	D POSTALB^XIPUTIL(DGZIP,.DGDATA)
-	 ;DG*730 - later commented out by DG*760
-	;I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
-	I $D(DGDATA("ERROR")) D  G ZAGN
-	. W $C(7)," ??"
-	Q DGZIP
-CITY(RESULT,ZIP,DFN)	;Base on zip, let user input city(#.114)
-	; Input:
-	;   ZIP - user input zip for the patient primary address
-	;   DFN - Interal entry number of Patient File (#2)
-	; Output:RESULT=-1 (input error or timed or ^ out) 
-	;        or    =user input city
-	;        Array index # of selected city.
-	K RESULT
-	N DGDATA,DIR,DA,Y,DTOUT,DUOUT,DIROUT,DGIND
-	N DGCITY,DGST,DGCNTY,DGABRV,DGN,DGECH,DGSOC
-	N DOLDCITY,DGSAME,DGELEVEN
-	; DG*760 brought in DGCITI
-	N DGCITI
-	S DGIND=""
-	D POSTALB^XIPUTIL(ZIP,.DGDATA)
-	;DG*730 - later commented out by DG*760
-	;I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
-	D FIELD^DID(2,.114,"N","LABEL","DGCITY")
-	S DGN=""
-	I '$D(DGDATA("ERROR")) D
-	. S DOLDCITY=$$GET1^DIQ(2,DFN_",",.114)
-	. S DGSAME=0
-	. F  S DGN=$O(DGDATA(DGN)) Q:DGN=""  D
-	.. S DGCITI=$P($G(DGDATA(DGN,"CITY")),"*",1)
-	.. S DGABRV=$G(DGDATA(DGN,"CITY ABBREVIATION"))
-	.. I DOLDCITY'="",DGCITI=DOLDCITY!(DGABRV=DOLDCITY) S DGSAME=1
-	.. ; next 4 commented out lines done by DG*760
-	.. ;I DGABRV="" S DGABRV=$P($G(DGDATA(DGN,"CITY")),"*",1)
-	.. ;I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
-	.. ;I $G(DGDATA(DGN,"CITY"))["*" S:DGABRV'="" DGABRV=DGABRV_"*"
-	.. I $G(DGDATA(DGN,"CITY"))["*" S DGCITI=DGCITI_"*"
-	.. ;S DGECH=DGN_":"_DGABRV
-	.. S DGECH=DGN_":"_DGCITI
-	.. S DGSOC=$S($G(DGSOC)="":DGECH,1:DGSOC_";"_DGECH)
-	.. S DGTOT=DGN
-	.I 'DGSAME S DGELEVEN=$G(^DPT(DFN,.11)) D
-	..Q:$P(DGELEVEN,U,6)'=$G(DGDATA(DGTOT,"POSTAL CODE"))
-	..Q:$P(DGELEVEN,U,14)'="VAMC"
-	..Q:$P(DGELEVEN,U,15)'=$$GETSITE^DGMTU4($G(DUZ))
-	..Q:$P(DGELEVEN,U,17)'>.5
-	..S DGN=DGTOT+1,DGECH=DGN_":"_DOLDCITY,DGSOC=DGSOC_";"_DGECH
-	.;
-	. I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) D
-	.. S DGSOC=$G(DGSOC)_";"_99_":"_"FREE TEXT"
-	. S DIR(0)="SO^"_$G(DGSOC)
-	. ;if zip '= zip on file, default = ""; else default=city on file
-	. ;I ($G(DFN)'="")&($E(ZIP,1,5)=$$GET1^DIQ(2,DFN_",",.116)) D
-	. S DIR("B")=$$GET1^DIQ(2,DFN_",",.114)
-	. S DIR("A")=$G(DGCITY("LABEL"))
-CAGN1	. D ^DIR
-	. I $D(DTOUT) S RESULT=-1 Q
-	. I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN1
-	. S RESULT=$P($G(Y(0)),"*")
-	. S DGIND=$G(Y)
-	I ($G(Y)=99)!($D(DGDATA("ERROR"))) D
-CAGN2	. I '$D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q
-	. N DIR,X,Y
-	. S DIR(0)="2,.114"
-	. S DA=DFN
-	. D ^DIR
-	. I $D(DTOUT) S RESULT=-1 Q
-	. I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN2
-	. S RESULT=$G(Y)
-	I $L($G(RESULT))>15 D
-	. S DGN=Y
-	. S RESULT=$G(DGDATA(DGN,"CITY ABBREVIATION"))
-	Q DGIND
-	;
-LINK(RESULT,ZIP,DGN)	;From zip, get the linked state,county
-	K RESULT
-	N DGDATA,CNTYIEN
-	S CNTYIEN=""
-	S DGN=$G(DGN)
-	I (DGN="")&($$MLT^DGREGDD1(ZIP)) S DGN=1
-	I (DGN=99)&($$MLT^DGREGDD1(ZIP)) S DGN=1
-	I (DGN="")!(DGN=99) Q
-	D POSTALB^XIPUTIL(ZIP,.DGDATA)
-	S:$G(DGDATA(DGN,"STATE POINTER"))'="" CNTYIEN=$$FIND1^DIC(5.01,","_$G(DGDATA(DGN,"STATE POINTER"))_",","MOXQ",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),"C")
-	D:'CNTYIEN  ;could be duplicate county codes in subfile #5.01
-	.Q:'$D(^DIC(5,+$G(DGDATA(DGN,"STATE POINTER")),1))
-	.Q:$E($G(DGDATA(DGN,"FIPS CODE")),3,5)=""
-	.S CNTYIEN=$O(^DIC(5,$G(DGDATA(DGN,"STATE POINTER")),1,"C",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),""))
-	S RESULT(.115)=$G(DGDATA(DGN,"STATE"))_U_$G(DGDATA(DGN,"STATE POINTER"))
-	S RESULT(.117)=$G(DGDATA(DGN,"COUNTY"))_U_$G(CNTYIEN)_U_$E($G(DGDATA(DGN,"FIPS CODE")),3,5)
-	Q
-	;
-STCNTY(RESULT,ZIP,DFN,DGNUM)	;Based on zip,input state (#.115) and county (#.117)
-	K RESULT
-	S DGNUM=$G(DGNUM)
-	N DGN,DGDFLT,DGST,POP,DIR,X,Y,DTOUT,DUOUT,DIROUT
-	S POP=0
-	D LINK(.DGDFLT,ZIP,DGNUM)
-	F DGN=.115,.117 Q:POP  D
-SCAGN	. I DGN=.115 S DIR(0)=2_","_DGN
-	. I ($G(DGST)="")&(DGN=.117) Q
-	. I DGN=.117 S DIR(0)="POA^DIC(5,DGST,1,:AEMQ"
-	. S DIR("B")=$P($G(DGDFLT(DGN)),U)
-	. D ^DIR
-	. I $D(DTOUT) S POP=1 Q
-	. I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G SCAGN
-	. S RESULT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U)
-	. I DGN=.115 S DGST=$P($G(Y),U)
-	. I DGN=.117 S RESULT(.117)=$$CNTY(DGST,$P($G(RESULT(.117)),U,2))
-	I POP=1 S RESULT=-1
-	Q
-CNTY(DGST,DGCIEN)	;Return county name and code
-	;Input:state number and county IEN
-	;Output: CountyName^CountyIEN^CountyCode
-	I ($G(DGST)="")!($G(DGCIEN)="") S RESULT=-1 Q RESULT
-	N DGR,RESULT
-	S DGR=$G(^DIC(5,DGST,1,DGCIEN,0))
-	S RESULT=$P($G(DGR),U)_U_DGCIEN_U_$P($G(DGR),U,3)
-	Q RESULT
-FOREIGN()	;Manila (Philippines) doesn't need zip linking.
-	;Output: 1 - area need no zip linking
-	;        0 - zip-linking area
-	I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=358 Q 1
-	;;;I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=500 Q 1 ;;HERE TEST
-	Q 0
-FRGNEDT(DGINPUT,DFN)	;Edit zip+4, city, state, county for no zip-linking area
-	K DGINPUT
-	N DGN,DIR,DTOUT,DUOUT,DIROUT,X,Y,POP,DGST
-	S POP=0
-	F DGN=.1112,.114,.115,.117 Q:POP  D
-FAGN	. I ($G(DGST)="")&(DGN=.117) Q
-	. S DIR(0)=2_","_DGN
-	. I DGN=.117 D
-	.. S DIR(0)="POA^DIC(5,DGST,1,:AEMQ"
-	.. S DIR("B")=$$GET1^DIQ(2,DFN_",",.117)
-	. I DGN'=.117 S DA=DFN
-	. D ^DIR
-	. I $D(DTOUT) S POP=1 Q
-	. I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G FAGN
-	. I (DGN=.114)!(DGN=.1112) S DGINPUT(DGN)=$G(Y)
-	. I (DGN=.115) D
-	.. S DGST=$P($G(Y),U)
-	.. I DGST=$$GET1^DIQ(2,DFN_",",.115,"I") D
-	... S DGINPUT(.115)=$$GET1^DIQ(2,DFN_",",.115)_U_DGST
-	.. I DGST'=$$GET1^DIQ(2,DFN_",",.115,"I") D
-	... S DGINPUT(.115)=$P($G(Y(0)),U)_U_DGST
-	. I DGN=.117 S DGINPUT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U)
-	I POP=1 S RESULT=-1
-	Q
+DGREGAZL ;ALB/DW - ZIP LINKING UTILITY ; 5/27/04 10:54am
+ ;;5.3;Registration;**522,560,581,730**;Aug 13, 1993;Build 2
+ ;
+EN(RESULT,DFN) ;Let user edit zip+4, city, state, county based on zip-linking
+ ; Output: RESULT(field#) = User Input External ^ Internal
+ K RESULT
+ N DGIND,DGTOT
+ I $G(DFN)="" S RESULT=-1 Q
+ N DGR,DGDFLT,DGALW,DGZIP,DGN
+ S DGN=""
+ I $$FOREIGN() D  Q
+ . D FRGNEDT(.DGR,DFN)
+ . I $G(DGR)=-1 S RESULT=-1 Q
+ . F DGN=.1112,.114,.115,.117 S RESULT(DGN)=$G(DGR(DGN))
+ S DGZIP=$$ZIP(DFN)
+ I DGZIP=-1 S RESULT=-1 Q
+ S RESULT(.1112)=DGZIP
+ S DGIND=$$CITY(.DGR,DGZIP,DFN)
+ I DGIND=$G(DGTOT)+1 S DGIND=""
+ I $G(DGR)=-1 S RESULT=-1 Q
+ S RESULT(.114)=$G(DGR)
+ S DGALW=$$ALWEDT^DGREGDD1($G(DUZ),DGZIP)
+ I DGALW=1 D
+ . K DGR D STCNTY(.DGR,DGZIP,DFN,DGIND)
+ . I $G(DGR)=-1 S RESULT=-1 Q
+ . S RESULT(.115)=$G(DGR(.115))
+ . S RESULT(.117)=$G(DGR(.117))
+ I DGALW=0 D
+ . I DGZIP'="" D LINK(.DGDFLT,DGZIP,1)
+ . S RESULT(.115)=$G(DGDFLT(.115))
+ . S RESULT(.117)=$G(DGDFLT(.117))
+ Q
+ZIP(DFN) ;Let user input zip+4
+ZAGN N DIR,DTOUT,DUOUT,DIROUT,DGDATA
+ S DIR(0)="2,.1112"
+ S DA=DFN
+ D ^DIR
+ I $D(DTOUT) Q -1
+ I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G ZAGN
+ S DGZIP=$G(Y)
+ ;allow bogus zip:
+ I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q DGZIP
+ I DGZIP="" Q DGZIP
+ D POSTALB^XIPUTIL(DGZIP,.DGDATA)
+  ;DG*730
+ I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
+ I $D(DGDATA("ERROR")) D  G ZAGN
+ . W $C(7)," ??"
+ Q DGZIP
+CITY(RESULT,ZIP,DFN) ;Base on zip, let user input city(#.114)
+ ; Input:
+ ;   ZIP - user input zip for the patient primary address
+ ;   DFN - Interal entry number of Patient File (#2)
+ ; Output:RESULT=-1 (input error or times or ^ out) 
+ ;        or    =user input city
+ ;        Array index # of selected city.
+ K RESULT
+ N DGDATA,DIR,DA,Y,DTOUT,DUOUT,DIROUT,DGIND
+ N DGCITY,DGST,DGCNTY,DGABRV,DGN,DGECH,DGSOC
+ N DOLDCITY,DGSAME,DGELEVEN
+ S DGIND=""
+ D POSTALB^XIPUTIL(ZIP,.DGDATA)
+ ;DG*730
+ I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
+ D FIELD^DID(2,.114,"N","LABEL","DGCITY")
+ S DGN=""
+ I '$D(DGDATA("ERROR")) D
+ . S DOLDCITY=$$GET1^DIQ(2,DFN_",",.114)
+ . S DGSAME=0
+ . F  S DGN=$O(DGDATA(DGN)) Q:DGN=""  D
+ .. S DGABRV=$G(DGDATA(DGN,"CITY ABBREVIATION"))
+ .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
+ .. I DGABRV="" S DGABRV=$P($G(DGDATA(DGN,"CITY")),"*",1)
+ .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
+ .. I $G(DGDATA(DGN,"CITY"))["*" S:DGABRV'="" DGABRV=DGABRV_"*"
+ .. S DGECH=DGN_":"_DGABRV
+ .. S DGSOC=$S($G(DGSOC)="":DGECH,1:DGSOC_";"_DGECH)
+ .. S DGTOT=DGN
+ .I 'DGSAME S DGELEVEN=$G(^DPT(DFN,.11)) D
+ ..Q:$P(DGELEVEN,U,6)'=$G(DGDATA(DGTOT,"POSTAL CODE"))
+ ..Q:$P(DGELEVEN,U,14)'="VAMC"
+ ..Q:$P(DGELEVEN,U,15)'=$$GETSITE^DGMTU4($G(DUZ))
+ ..Q:$P(DGELEVEN,U,17)'>.5
+ ..S DGN=DGTOT+1,DGECH=DGN_":"_DOLDCITY,DGSOC=DGSOC_";"_DGECH
+ .;
+ . I $D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) D
+ .. S DGSOC=$G(DGSOC)_";"_99_":"_"FREE TEXT"
+ . S DIR(0)="SO^"_$G(DGSOC)
+ . ;if zip '= zip on file, default = ""; else default=city on file
+ . ;I ($G(DFN)'="")&($E(ZIP,1,5)=$$GET1^DIQ(2,DFN_",",.116)) D
+ . S DIR("B")=$$GET1^DIQ(2,DFN_",",.114)
+ . S DIR("A")=$G(DGCITY("LABEL"))
+CAGN1 . D ^DIR
+ . I $D(DTOUT) S RESULT=-1 Q
+ . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN1
+ . S RESULT=$P($G(Y(0)),"*")
+ . S DGIND=$G(Y)
+ I ($G(Y)=99)!($D(DGDATA("ERROR"))) D
+CAGN2 . I '$D(^XUSEC("EAS GMT COUNTY EDIT",+DUZ)) Q
+ . N DIR,X,Y
+ . S DIR(0)="2,.114"
+ . S DA=DFN
+ . D ^DIR
+ . I $D(DTOUT) S RESULT=-1 Q
+ . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN2
+ . S RESULT=$G(Y)
+ I $L($G(RESULT))>15 S RESULT=$E(RESULT,1,15)
+ Q DGIND
+ ;
+LINK(RESULT,ZIP,DGN) ;From zip, get the linked state,county
+ K RESULT
+ N DGDATA,CNTYIEN
+ S CNTYIEN=""
+ S DGN=$G(DGN)
+ I (DGN="")&($$MLT^DGREGDD1(ZIP)) S DGN=1
+ I (DGN=99)&($$MLT^DGREGDD1(ZIP)) S DGN=1
+ I (DGN="")!(DGN=99) Q
+ D POSTALB^XIPUTIL(ZIP,.DGDATA)
+ S:$G(DGDATA(DGN,"STATE POINTER"))'="" CNTYIEN=$$FIND1^DIC(5.01,","_$G(DGDATA(DGN,"STATE POINTER"))_",","MOXQ",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),"C")
+ D:'CNTYIEN  ;could be duplicate county codes in subfile #5.01
+ .Q:'$D(^DIC(5,+$G(DGDATA(DGN,"STATE POINTER")),1))
+ .Q:$E($G(DGDATA(DGN,"FIPS CODE")),3,5)=""
+ .S CNTYIEN=$O(^DIC(5,$G(DGDATA(DGN,"STATE POINTER")),1,"C",$E($G(DGDATA(DGN,"FIPS CODE")),3,5),""))
+ S RESULT(.115)=$G(DGDATA(DGN,"STATE"))_U_$G(DGDATA(DGN,"STATE POINTER"))
+ S RESULT(.117)=$G(DGDATA(DGN,"COUNTY"))_U_$G(CNTYIEN)_U_$E($G(DGDATA(DGN,"FIPS CODE")),3,5)
+ Q
+ ;
+STCNTY(RESULT,ZIP,DFN,DGNUM) ;Based on zip,input state (#.115) and county (#.117)
+ K RESULT
+ S DGNUM=$G(DGNUM)
+ N DGN,DGDFLT,DGST,POP,DIR,X,Y,DTOUT,DUOUT,DIROUT
+ S POP=0
+ D LINK(.DGDFLT,ZIP,DGNUM)
+ F DGN=.115,.117 Q:POP  D
+SCAGN . I DGN=.115 S DIR(0)=2_","_DGN
+ . I ($G(DGST)="")&(DGN=.117) Q
+ . I DGN=.117 S DIR(0)="POA^DIC(5,DGST,1,:AEMQ"
+ . S DIR("B")=$P($G(DGDFLT(DGN)),U)
+ . D ^DIR
+ . I $D(DTOUT) S POP=1 Q
+ . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G SCAGN
+ . S RESULT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U)
+ . I DGN=.115 S DGST=$P($G(Y),U)
+ . I DGN=.117 S RESULT(.117)=$$CNTY(DGST,$P($G(RESULT(.117)),U,2))
+ I POP=1 S RESULT=-1
+ Q
+CNTY(DGST,DGCIEN) ;Return county name and code
+ ;Input:state number and county IEN
+ ;Output: CountyName^CountyIEN^CountyCode
+ I ($G(DGST)="")!($G(DGCIEN)="") S RESULT=-1 Q RESULT
+ N DGR,RESULT
+ S DGR=$G(^DIC(5,DGST,1,DGCIEN,0))
+ S RESULT=$P($G(DGR),U)_U_DGCIEN_U_$P($G(DGR),U,3)
+ Q RESULT
+FOREIGN() ;Manila (Philippines) doesn't need zip linking.
+ ;Output: 1 - area need no zip linking
+ ;        0 - zip-linking area
+ I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=358 Q 1
+ ;;;I $$STA^XUAF4(+$$KSP^XUPARAM("INST"))=500 Q 1 ;;HERE TEST
+ Q 0
+FRGNEDT(DGINPUT,DFN) ;Edit zip+4, city, state, county for no zip-linking area
+ K DGINPUT
+ N DGN,DIR,DTOUT,DUOUT,DIROUT,X,Y,POP,DGST
+ S POP=0
+ F DGN=.1112,.114,.115,.117 Q:POP  D
+FAGN . I ($G(DGST)="")&(DGN=.117) Q
+ . S DIR(0)=2_","_DGN
+ . I DGN=.117 D
+ .. S DIR(0)="POA^DIC(5,DGST,1,:AEMQ"
+ .. S DIR("B")=$$GET1^DIQ(2,DFN_",",.117)
+ . I DGN'=.117 S DA=DFN
+ . D ^DIR
+ . I $D(DTOUT) S POP=1 Q
+ . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G FAGN
+ . I (DGN=.114)!(DGN=.1112) S DGINPUT(DGN)=$G(Y)
+ . I (DGN=.115) D
+ .. S DGST=$P($G(Y),U)
+ .. I DGST=$$GET1^DIQ(2,DFN_",",.115,"I") D
+ ... S DGINPUT(.115)=$$GET1^DIQ(2,DFN_",",.115)_U_DGST
+ .. I DGST'=$$GET1^DIQ(2,DFN_",",.115,"I") D
+ ... S DGINPUT(.115)=$P($G(Y(0)),U)_U_DGST
+ . I DGN=.117 S DGINPUT(DGN)=$P($G(Y),U,2)_U_$P($G(Y),U)
+ I POP=1 S RESULT=-1
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m	(revision 623)
@@ -1,223 +1,223 @@
-DGRP1	;ALB/MRL - DEMOGRAPHIC DATA ;1/8/07  09:14
-	;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-	;
-	; 2005 03 18 (VA/JT): DG*5.3*629, stop Missing Patient message based
-	; on questionable data in Missing Person Date fld (.153).
-	;
-	; 2005 04 25? (VA/MRY): DG*5.3*638, add Sex to IDs shown.
-	;
-	; 2005 04 27 (VA/JT): DG*5.3*649, change last $EXTRACT for Alias SSN in
-	; GETNCAL to 10 chars instead of 9, to preserve trailing P for pseudo-
-	; SSNs.
-	;
-	; 2006 04 21 (WV/TOAD, after DAOU/WCJ (2005 02 07) and
-	; VA/CJS (2005/12/23)): restore 6-part VOE change; space dots and
-	; semi-colons.
-	;
-	; 2006 05 09 (WV/TOAD): rewrite VOE change to fix bugs introduced by
-	; VA and VOE, and completely refactor bug-prone GETNCAL, and merge back
-	; into main subroutine body.
-	;
-EN	S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
-	I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
-	;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'.  NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
-	;
-	; ** VOE change 1 of 3 **
-	;
-	; if EHR agency code, display Registration Date (Date Entered into
-	; File, .097)
-	;
-	; new lines:
-	I $G(DUZ("AG"))="E" D
-	. W !?58,"Reg Dt: ",$$FMTE^XLFDT($P(DGRP(0),U,16),"2D")
-	;
-	;
-	; show field groups 1 and 2 in two columns
-	;
-	; field groups 1 & 2 part 1: show Name, SSN, and DOB
-	;
-	;
-	; ** end of VOE change 1 **
-	;
-	W ! S Z=1 D WW^DGRPV W "    Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
-	W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV
-	W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
-	;add Pseudo SSN Reason - DG*5.3*653, ERC
-	I $P(DGRP(0),U,9)["P" D
-	. N DGSPACE
-	. S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen
-	. S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: "
-	. I $P(DGRP(0),U,9)["P" D
-	. . N DGREAS D SSNREAS(.DGREAS)
-	. . Q:$G(DGREAS)']""
-	. . W DGREAS
-	;
-	; ** VOE change 2 of 3 **
-	;
-	; eliminate unnecessary subroutine GETNCAL and merge code back into
-	; the main subroutine, and make the following changes:
-	;
-	; For EHR or IHS agency code, show Health Record No. (.02) for the
-	; current Facility from the Health Record No. multiple field
-	; (4101/9000001.41) of the IHS Patient file (9000001) for the current
-	; patient.
-	;
-	; Move Sex field over so it shows up in the same location for
-	; VA, IHS, and EHR, leaving a blank for where HRN can appear.
-	;
-	; Fix the VA bug in which patients having five valid aliases
-	; were showing "< More alias entries on file >" instead of the fifth
-	; alias.
-	;
-	; Refactor entire subroutine: clean original design was broken
-	; by patching and had become fragile and confusing; tighten variable
-	; scopes, use clearer names, comment.
-	;
-	; before:
-	;
-	; D GETNCAL  ;Display name component, sex, and alias information
-	;
-	; after:
-	;
-	; field groups 1 & 2 part 2: load name components
-	;
-	;
-	N DGLABEL S DGLABEL="^ Given^Middle^Prefix^Suffix^Degree" ; labels
-	N DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," ; Name Components fd (1.01)
-	I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") ; Name Components file
-	; loads Family (Last) Name (1), Given (First) Name (2),
-	; Middle Name (3), Prefix (4), Suffix (5), and Degree (6)
-	;
-	;
-	; field groups 1 & 2 part 3: load aliases
-	;
-	;
-	N DGCOUNT S DGCOUNT=0 ; how many aliases do we find
-	N DGALIAS S DGALIAS=0 ; IEN of Alias subfile (1/2.01) of Patient fl (2)
-	;                       and array of aliases found
-	S DGALIAS=0 F  D  Q:'DGALIAS
-	. ;
-	. S DGALIAS=$O(^DPT(DFN,.01,DGALIAS))
-	. Q:'DGALIAS  ; out of alias subrecords
-	. N DGNODE S DGNODE=$G(^DPT(DFN,.01,DGALIAS,0)) ; 0-node of subrecord
-	. Q:'$L(DGNODE)  ; bad node
-	. ;
-	. S DGCOUNT=DGCOUNT+1 ; another valid alias
-	. I DGCOUNT=6 S DGALIAS=0 Q  ; can't show > 5, need to know if 6 or >
-	. ;
-	. S DGALIAS(DGCOUNT)=$P(DGNODE,U) ; Alias fld (.01)
-	. ;
-	. N DGSSN S DGSSN=$P(DGNODE,U,2) ; Alias SSN fld (1)
-	. I $L(DGSSN) D
-	. . S DGSSN=" "_$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10)
-	. . ; incl leading space to separate from alias name
-	. . ; incl 10 chars to allow for P of pseudo-SSNs
-	. . S $E(DGALIAS(DGCOUNT),20)=DGSSN ; truncate alias name & append SSN
-	. ;
-	. S DGALIAS(DGCOUNT)=$E(DGALIAS(DGCOUNT),1,32) ; truncate alias
-	;
-	I DGCOUNT=0 S DGALIAS(1)="< No alias entries on file >"
-	I DGCOUNT=6 S DGALIAS(5)="< More alias entries on file >"
-	K DGCOUNT
-	;
-	;
-	; field groups 1 & 2 part 4: show 1st name component, and IDs HRN & Sex
-	;
-	;
-	W !?5,"Family: "
-	W $E($G(DGCOMP(20,DGCOMP,1)),1,27)
-	;
-	I "EI"[$G(DUZ("AG")),$G(DUZ(2)) D
-	. N DGNODE S DGNODE=$G(^AUPNPAT(DFN,41,DUZ(2),0)) ; get 0-node for the
-	. ; current Facility from the Health Record No. multiple field
-	. ; (4101/9000001.41) for DFN in the IHS Patient file (9000001)
-	. N DGHRN S DGHRN=$P(DGNODE,U,2) ; Health Record No. (.02)
-	. W ?42," HRN: ",DGHRN
-	;
-	D
-	. N DGSEX S DGSEX=$P(DGRP(0),U,2) ; Sex fld (.02) of Patient file (2)
-	. W ?61,"Sex: ",$S(DGSEX="M":"MALE",DGSEX="F":"FEMALE",1:"UNANSWERED")
-	;
-	;
-	; field groups 1 & 2 part 5: show remaining name components and aliases
-	;
-	;
-	N DGCOUNT F DGCOUNT=2:1:6 D
-	. W !?5,$P(DGLABEL,U,DGCOUNT),": "
-	. N DGNAME S DGNAME=$G(DGCOMP(20,DGCOMP,DGCOUNT)) ; next name component
-	. W $E(DGNAME,1,$S(DGCOUNT=2:23,1:27)) ; 1st line leaves room for "[2]"
-	. I DGCOUNT=2 D  ; header for aliases
-	. . W ?37 N DGRPW,Z S DGRPW=0,Z=2 D WW^DGRPV ; write [2], suppress LF
-	. . W " Alias: "
-	. W ?47,$G(DGALIAS(DGCOUNT-1)) ; show next alias
-	;
-	;
-	; show field group 3: remarks
-	;
-	;
-	; ** end of VOE change 2 **
-	;
-	S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
-	S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
-	D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: "
-	W !?11
-	S Z1=40,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
-	S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>50) !?11 W:'(I#2) ?51 W DGA(I)
-	S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?3,"County: ",DGCC K DGCC
-	S DGCC=$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(.121),U,5),1,+$P(DGRP(.121),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W ?43,"County: ",DGCC K DGCC
-	W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
-	S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
-	W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
-	;
-	; ** VOE change 3 of 3 **
-	;
-	; if EHR agency code, display Alternate Phone Number (.134)
-	;
-	; new lines:
-	I $G(DUZ("AG"))="E" D
-	. W !?1,"Alt Ph: ",$P($G(^DPT(DFN,.13)),U,4)
-	;
-	; ** end of VOE change 3 **
-	;
-	W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
-	;
-	; ***  Additional displays added for Pre-Registration
-	I $G(DGPRFLG)=1 D
-	. W !
-	. N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1
-	. I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1  I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2)
-	. W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
-	. I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1  S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2)
-	. W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
-	. I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1  S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2)
-	. W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
-	. I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1  S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2)
-	. W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
-	. ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
-	. I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI  D
-	.. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
-	.. W "  EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D"),"  EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
-	;
-	G ^DGRPP
-	;
-SSNREAS(DGREAS)	;get Pseuso SSN Reason - DG*5.3*653, ERC
-	S DGREAS=$P(DGRP("SSN"),U)
-	I $G(DGREAS)']"" Q
-	S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >")
-	Q
+DGRP1 ;ALB/MRL - DEMOGRAPHIC DATA ;1/8/07  09:14
+ ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ; 2005 03 18 (VA/JT): DG*5.3*629, stop Missing Patient message based
+ ; on questionable data in Missing Person Date fld (.153).
+ ;
+ ; 2005 04 25? (VA/MRY): DG*5.3*638, add Sex to IDs shown.
+ ;
+ ; 2005 04 27 (VA/JT): DG*5.3*649, change last $EXTRACT for Alias SSN in
+ ; GETNCAL to 10 chars instead of 9, to preserve trailing P for pseudo-
+ ; SSNs.
+ ;
+ ; 2006 04 21 (WV/TOAD, after DAOU/WCJ (2005 02 07) and
+ ; VA/CJS (2005/12/23)): restore 6-part VOE change; space dots and
+ ; semi-colons.
+ ;
+ ; 2006 05 09 (WV/TOAD): rewrite VOE change to fix bugs introduced by
+ ; VA and VOE, and completely refactor bug-prone GETNCAL, and merge back
+ ; into main subroutine body.
+ ;
+EN S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
+ I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
+ ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'.  NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
+ ;
+ ; ** VOE change 1 of 3 **
+ ;
+ ; if EHR agency code, display Registration Date (Date Entered into
+ ; File, .097)
+ ;
+ ; new lines:
+ I $G(DUZ("AG"))="E" D
+ . W !?58,"Reg Dt: ",$$FMTE^XLFDT($P(DGRP(0),U,16),"2D")
+ ;
+ ;
+ ; show field groups 1 and 2 in two columns
+ ;
+ ; field groups 1 & 2 part 1: show Name, SSN, and DOB
+ ;
+ ;
+ ; ** end of VOE change 1 **
+ ;
+ W ! S Z=1 D WW^DGRPV W "    Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
+ W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV
+ W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
+ ;add Pseudo SSN Reason - DG*5.3*653, ERC
+ I $P(DGRP(0),U,9)["P" D
+ . N DGSPACE
+ . S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen
+ . S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: "
+ . I $P(DGRP(0),U,9)["P" D
+ . . N DGREAS D SSNREAS(.DGREAS)
+ . . Q:$G(DGREAS)']""
+ . . W DGREAS
+ ;
+ ; ** VOE change 2 of 3 **
+ ;
+ ; eliminate unnecessary subroutine GETNCAL and merge code back into
+ ; the main subroutine, and make the following changes:
+ ;
+ ; For EHR or IHS agency code, show Health Record No. (.02) for the
+ ; current Facility from the Health Record No. multiple field
+ ; (4101/9000001.41) of the IHS Patient file (9000001) for the current
+ ; patient.
+ ;
+ ; Move Sex field over so it shows up in the same location for
+ ; VA, IHS, and EHR, leaving a blank for where HRN can appear.
+ ;
+ ; Fix the VA bug in which patients having five valid aliases
+ ; were showing "< More alias entries on file >" instead of the fifth
+ ; alias.
+ ;
+ ; Refactor entire subroutine: clean original design was broken
+ ; by patching and had become fragile and confusing; tighten variable
+ ; scopes, use clearer names, comment.
+ ;
+ ; before:
+ ;
+ ; D GETNCAL  ;Display name component, sex, and alias information
+ ;
+ ; after:
+ ;
+ ; field groups 1 & 2 part 2: load name components
+ ;
+ ;
+ N DGLABEL S DGLABEL="^ Given^Middle^Prefix^Suffix^Degree" ; labels
+ N DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," ; Name Components fd (1.01)
+ I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") ; Name Components file
+ ; loads Family (Last) Name (1), Given (First) Name (2),
+ ; Middle Name (3), Prefix (4), Suffix (5), and Degree (6)
+ ;
+ ;
+ ; field groups 1 & 2 part 3: load aliases
+ ;
+ ;
+ N DGCOUNT S DGCOUNT=0 ; how many aliases do we find
+ N DGALIAS S DGALIAS=0 ; IEN of Alias subfile (1/2.01) of Patient fl (2)
+ ;                       and array of aliases found
+ S DGALIAS=0 F  D  Q:'DGALIAS
+ . ;
+ . S DGALIAS=$O(^DPT(DFN,.01,DGALIAS))
+ . Q:'DGALIAS  ; out of alias subrecords
+ . N DGNODE S DGNODE=$G(^DPT(DFN,.01,DGALIAS,0)) ; 0-node of subrecord
+ . Q:'$L(DGNODE)  ; bad node
+ . ;
+ . S DGCOUNT=DGCOUNT+1 ; another valid alias
+ . I DGCOUNT=6 S DGALIAS=0 Q  ; can't show > 5, need to know if 6 or >
+ . ;
+ . S DGALIAS(DGCOUNT)=$P(DGNODE,U) ; Alias fld (.01)
+ . ;
+ . N DGSSN S DGSSN=$P(DGNODE,U,2) ; Alias SSN fld (1)
+ . I $L(DGSSN) D
+ . . S DGSSN=" "_$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10)
+ . . ; incl leading space to separate from alias name
+ . . ; incl 10 chars to allow for P of pseudo-SSNs
+ . . S $E(DGALIAS(DGCOUNT),20)=DGSSN ; truncate alias name & append SSN
+ . ;
+ . S DGALIAS(DGCOUNT)=$E(DGALIAS(DGCOUNT),1,32) ; truncate alias
+ ;
+ I DGCOUNT=0 S DGALIAS(1)="< No alias entries on file >"
+ I DGCOUNT=6 S DGALIAS(5)="< More alias entries on file >"
+ K DGCOUNT
+ ;
+ ;
+ ; field groups 1 & 2 part 4: show 1st name component, and IDs HRN & Sex
+ ;
+ ;
+ W !?5,"Family: "
+ W $E($G(DGCOMP(20,DGCOMP,1)),1,27)
+ ;
+ I "EI"[$G(DUZ("AG")),$G(DUZ(2)) D
+ . N DGNODE S DGNODE=$G(^AUPNPAT(DFN,41,DUZ(2),0)) ; get 0-node for the
+ . ; current Facility from the Health Record No. multiple field
+ . ; (4101/9000001.41) for DFN in the IHS Patient file (9000001)
+ . N DGHRN S DGHRN=$P(DGNODE,U,2) ; Health Record No. (.02)
+ . W ?42," HRN: ",DGHRN
+ ;
+ D
+ . N DGSEX S DGSEX=$P(DGRP(0),U,2) ; Sex fld (.02) of Patient file (2)
+ . W ?61,"Sex: ",$S(DGSEX="M":"MALE",DGSEX="F":"FEMALE",1:"UNANSWERED")
+ ;
+ ;
+ ; field groups 1 & 2 part 5: show remaining name components and aliases
+ ;
+ ;
+ N DGCOUNT F DGCOUNT=2:1:6 D
+ . W !?5,$P(DGLABEL,U,DGCOUNT),": "
+ . N DGNAME S DGNAME=$G(DGCOMP(20,DGCOMP,DGCOUNT)) ; next name component
+ . W $E(DGNAME,1,$S(DGCOUNT=2:23,1:27)) ; 1st line leaves room for "[2]"
+ . I DGCOUNT=2 D  ; header for aliases
+ . . W ?37 N DGRPW,Z S DGRPW=0,Z=2 D WW^DGRPV ; write [2], suppress LF
+ . . W " Alias: "
+ . W ?47,$G(DGALIAS(DGCOUNT-1)) ; show next alias
+ ;
+ ;
+ ; show field group 3: remarks
+ ;
+ ;
+ ; ** end of VOE change 2 **
+ ;
+ S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
+ S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
+ D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: "
+ W !?11
+ S Z1=40,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
+ S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>50) !?11 W:'(I#2) ?51 W DGA(I)
+ S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?3,"County: ",DGCC K DGCC
+ S DGCC=$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(.121),U,5),1,+$P(DGRP(.121),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W ?43,"County: ",DGCC K DGCC
+ W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
+ S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
+ W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
+ ;
+ ; ** VOE change 3 of 3 **
+ ;
+ ; if EHR agency code, display Alternate Phone Number (.134)
+ ;
+ ; new lines:
+ I $G(DUZ("AG"))="E" D
+ . W !?1,"Alt Ph: ",$P($G(^DPT(DFN,.13)),U,4)
+ ;
+ ; ** end of VOE change 3 **
+ ;
+ W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
+ ;
+ ; ***  Additional displays added for Pre-Registration
+ I $G(DGPRFLG)=1 D
+ . W !
+ . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1
+ . I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1  I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2)
+ . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
+ . I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1  S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2)
+ . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
+ . I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1  S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2)
+ . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
+ . I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1  S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2)
+ . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
+ . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
+ . I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI  D
+ .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
+ .. W "  EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D"),"  EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
+ ;
+ G ^DGRPP
+ ;
+SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
+ S DGREAS=$P(DGRP("SSN"),U)
+ I $G(DGREAS)']"" Q
+ S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >")
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP14.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP14.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP14.m	(revision 623)
@@ -1,38 +1,38 @@
-DGRP14	;ALB/MRL/EG/GAH - REGISTRATION SCREEN 14/APPOINTMENT INFORMATION ; 10/18/06
-	;;5.3;Registration;**568,585,725,770**;Aug 13, 1993;Build 4
-	S DGRPS=14 D H^DGRPU S (Z,DGRPW)=1 D WW^DGRPV W " Enrollment Clinics: "
-	S I1=""
-	F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I  D:$P(^(I,0),U,2)'="I"
-	. S I1=1,X=$S($D(^SC(+^(0),0)):$P(^(0),U,1)_", ",1:"")
-	. W:(79-$X)<$L(X) !?24 W X
-	W:'I1 "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME"
-	W ! S Z=2 D WW^DGRPV W "     Pending Appt's",?18,": " S I1="",I2=DT_".9999"
-	N DGARRAY,APTDT,CLIFN,CLNAM
-	S DGARRAY("FLDS")="1;2;3",DGARRAY(3)="R;I;NT",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
-	S I1=$$SDAPI^SDAMA301(.DGARRAY)
-	;Check for appointment retrieval error.
-	I I1<0 W $$FAPCHK^DGENRPD2 G Q
-	S APTDT=0
-	F  S APTDT=$O(^TMP($J,"SDAMA301",DFN,APTDT)) Q:'APTDT  D
-	.;check to see if appointment is cancelled, if so
-	.;ignore this appointment eg 01/25/2005
-	.;I $$CANCEL(DFN,APTDT)="Y" Q TAKEN OUT IN PATCH 770.
-	.S CLNAM=$P($P(^TMP($J,"SDAMA301",DFN,APTDT),U,2),";",2)
-	.S X=$S(CLNAM]"":CLNAM,1:"UNKNOWN CLINIC")_" ("_$$FMTE^DILIBF(APTDT,"5U")_"), " W:(79-$X)<$L(X) !?24 W X
-	.Q
-	I 'I1 W "NO PENDING APPOINTMENTS ON FILE"
-Q	K I,I1,I2,X,Y,DGARRAY,APTDT,CLNAM,^TMP($J,"SDAMA301") G ^DGRPP
-	;
-	;input DFN - patient id
-	;      APPDATE - appointment date
-	;return Y - Yes
-	;       N - No
-CANCEL(DFN,APPDATE)	;
-	N X,STATUS,U
-	S U="^"
-	S X=$G(^DPT(DFN,"S",APPDATE,0))
-	I X="" Q "Y"  ;probably bad data
-	S STATUS=$P(X,U,2)
-	I STATUS="" Q "N"
-	I STATUS="I" Q "N"
-	Q "Y"
+DGRP14 ;ALB/MRL/EG/GAH - REGISTRATION SCREEN 14/APPOINTMENT INFORMATION ; 10/18/06
+ ;;5.3;Registration;**568,585,725**;Aug 13, 1993;Build 12
+ S DGRPS=14 D H^DGRPU S (Z,DGRPW)=1 D WW^DGRPV W " Enrollment Clinics: "
+ S I1=""
+ F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I  D:$P(^(I,0),U,2)'="I"
+ . S I1=1,X=$S($D(^SC(+^(0),0)):$P(^(0),U,1)_", ",1:"")
+ . W:(79-$X)<$L(X) !?24 W X
+ W:'I1 "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME"
+ W ! S Z=2 D WW^DGRPV W "     Pending Appt's",?18,": " S I1="",I2=DT_".9999"
+ N DGARRAY,APTDT,CLIFN,CLNAM
+ S DGARRAY("FLDS")="1;2;3",DGARRAY(3)="R;I;NT",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
+ S I1=$$SDAPI^SDAMA301(.DGARRAY)
+ ;Check for appointment retrieval error.
+ I I1<0 W $$FAPCHK^DGENRPD2 G Q
+ S APTDT=0
+ F  S APTDT=$O(^TMP($J,"SDAMA301",DFN,APTDT)) Q:'APTDT  D
+ .;check to see if appointment is cancelled, if so
+ .;ignore this appointment eg 01/25/2005
+ .I $$CANCEL(DFN,APTDT)="Y" Q
+ .S CLNAM=$P($P(^TMP($J,"SDAMA301",DFN,APTDT),U,2),";",2)
+ .S X=$S(CLNAM]"":CLNAM,1:"UNKNOWN CLINIC")_" ("_$$FMTE^DILIBF(APTDT,"5U")_"), " W:(79-$X)<$L(X) !?24 W X
+ .Q
+ I 'I1 W "NO PENDING APPOINTMENTS ON FILE"
+Q K I,I1,I2,X,Y,DGARRAY,APTDT,CLNAM,^TMP($J,"SDAMA301") G ^DGRPP
+ ;
+ ;input DFN - patient id
+ ;      APPDATE - appointment date
+ ;return Y - Yes
+ ;       N - No
+CANCEL(DFN,APPDATE) ;
+ N X,STATUS,U
+ S U="^"
+ S X=$G(^DPT(DFN,"S",APPDATE,0))
+ I X="" Q "Y"  ;probably bad data
+ S STATUS=$P(X,U,2)
+ I STATUS="" Q "N"
+ I STATUS="I" Q "N"
+ Q "Y"
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP2.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP2.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP2.m	(revision 623)
@@ -1,107 +1,105 @@
-DGRP2	;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ;1:15 PM  10 Dec 2008
-	;;5.3;Registration;**415,545,638,677,760,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-	S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
-	S DGRPX=DGRP(0)
-	S (Z,DGRPW)=1 D WW^DGRPV W "  Marital: " S Z=$S($D(^DIC(11,+$P(DGRPX,"^",5),0)):$E($P(^(0),"^",1),1,28),1:DGRPU),Z1=30 D WW1^DGRPV
-	;S (Z,DGRPW)=1 D WW^DGRPV W "     Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=31 D WW1^DGRPV
-	S DGD=$$DISP^DG1010P0(DGRP(0),11,0,1),DGNOCITY=DGUNK,DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1)
-	W ?41,"POB: ",$E($S((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$S(($L(DGD)):", ",1:"")_DGD1),1,29)
-	;S DGRPX=DGRP(0)
-	W !?4,"Religion: ",$S($D(^DIC(13,+$P(DGRPX,"^",8),0)):$P(^(0),"^",1),1:DGRPU),?41,"Father: ",$S($P(DGRP(.24),"^",1)]"":$E($P(DGRP(.24),"^",1),1,29),1:DGRPU)
-	S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QP"[$E(X):X_"TRAUMATIC",1:X) W !?9,"SCI: ",X
-	W ?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU)
-	W !,?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU)
-	W ! S Z=2 D WW^DGRPV W " Previous Care Date      Location of Previous Care",!?4,"------------------      -------------------------" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X
-	E  F I=1:1:4 S I1=$P(DGRPX,"^",I) X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)" I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
-	;
-	; ** start of VOE change: DAOU,VA/CJS,WV/TOAD 1/5/2006 ** ;p634
-	;
-	; New VOE Patient fields
-	;
-	; insert 7 lines:
-	;
-	I $G(DUZ("AG"))="E" D
-	. W !?4,"Veteran: ",$$GET1^DIQ(2,DFN,19902)
-	. W !,"Interpreter Language: "
-	. N IL S IL=""
-	. N I F I=1:1 S IL=$O(^DPT(DFN,19901,"B",IL)) Q:IL=""  D
-	. . I I'=1 W ","
-	. . W $$GET1^DIQ(.85,IL,1)
-	;
-	; next three groups of lines have been conditionalized to only display
-	; for VA agency code; also, refactored for clarity
-	;
-	I $G(DUZ("AG"))="V" D
-	. W ! S Z=2 D WW^DGRPV
-	. W " Previous Care Date      Location of Previous Care"
-	. W !?4,"------------------      -------------------------"
-	. S DGRPX=DGRP(1010.15)
-	. ;
-	. I $P(DGRPX,"^",5)'="Y" D
-	. . S X="NONE INDICATED"
-	. . W !?4,X,?28,X
-	. ;
-	. E  F I=1:1:4 D
-	. . S I1=$P(DGRPX,"^",I)
-	. . X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)"
-	. . I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
-	;
-	; ** end of VOE change **; p634
-	;
-	W ! S Z=3 D WW^DGRPV W " Ethnicity: " D
-	.I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q
-	.N NODE,NUM,ETHNIC
-	.S I=0
-	.F NUM=0:1 S I=+$O(^DPT(DFN,.06,I)) Q:'I  D
-	..S NODE=$G(^DPT(DFN,.06,I,0))
-	..S X=$P($G(^DIC(10.2,+NODE,0)),"^",1)
-	..S ETHNIC=$S(X="":"?????",1:X)
-	..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
-	..S ETHNIC=ETHNIC_" ("_$S(X="":"?",1:X)_")"
-	..I NUM S ETHNIC=", "_ETHNIC
-	..I ($X+$L(ETHNIC))>IOM D  W !?15
-	...F  S X=$P(ETHNIC," ",1)_" " Q:($X+$L(X))>IOM  W X S ETHNIC=$P(ETHNIC," ",2,999)
-	..W ETHNIC
-	W !?9,"Race: " D
-	.I '$O(^DPT(DFN,.02,0)) W "UNANSWERED" Q
-	.N NODE,NUM,RACE
-	.S I=0
-	.F NUM=0:1 S I=+$O(^DPT(DFN,.02,I)) Q:'I  D
-	..S NODE=$G(^DPT(DFN,.02,I,0))
-	..S X=$P($G(^DIC(10,+NODE,0)),"^",1)
-	..S RACE=$S(X="":"?????",1:X)
-	..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
-	..S RACE=RACE_" ("_$S(X="":"?",1:X)_")"
-	..I NUM S RACE=", "_RACE
-	..I ($X+$L(RACE))>IOM D  W !?15
-	...F  S X=$P(RACE," ",1)_" " Q:($X+$L(X))>IOM  W X S RACE=$P(RACE," ",2,999)
-	..W RACE
-	D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
-	W !!
-	W "<4> Date of Death Information"
-	W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
-	W ?41,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
-	W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
-	W ?41,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
-	K PDTHINFO
-	;
-	;Emergency Response Indicator
-	N DGEMRES S DGEMRES=$P($G(^DPT(DFN,.18)),"^")
-	S Z=5 D WW^DGRPV W " Emergency Response: "_$$EXTERNAL^DILFD(2,.181,,DGEMRES)
-	G ^DGRPP
+DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ; 1/5/2006  23:54
+ ;;5.3;Registration;**415,545,638,677,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
+ S DGRPX=DGRP(0)
+ S (Z,DGRPW)=1 D WW^DGRPV W "  Marital: " S Z=$S($D(^DIC(11,+$P(DGRPX,"^",5),0)):$E($P(^(0),"^",1),1,28),1:DGRPU),Z1=30 D WW1^DGRPV
+ ;S (Z,DGRPW)=1 D WW^DGRPV W "     Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=31 D WW1^DGRPV
+ S DGD=$$DISP^DG1010P0(DGRP(0),11,0,1),DGNOCITY=DGUNK,DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1)
+ W ?41,"POB: ",$E($S((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$S(($L(DGD)):", ",1:"")_DGD1),1,29)
+ ;S DGRPX=DGRP(0)
+ W !?4,"Religion: ",$S($D(^DIC(13,+$P(DGRPX,"^",8),0)):$P(^(0),"^",1),1:DGRPU),?41,"Father: ",$S($P(DGRP(.24),"^",1)]"":$E($P(DGRP(.24),"^",1),1,29),1:DGRPU)
+ S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QD"[$E(X):X_"TRAUMATIC",1:X) W !?9,"SCI: ",X
+ W ?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU)
+ W !,?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU)
+ ;
+ ; ** start of VOE change: DAOU,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; New VOE Patient fields
+ ;
+ ; insert 7 lines:
+ ;
+ I $G(DUZ("AG"))="E" D
+ . W !?4,"Veteran: ",$$GET1^DIQ(2,DFN,19902)
+ . W !,"Interpreter Language: "
+ . N IL S IL=""
+ . N I F I=1:1 S IL=$O(^DPT(DFN,19901,"B",IL)) Q:IL=""  D
+ . . I I'=1 W ","
+ . . W $$GET1^DIQ(.85,IL,1)
+ ;
+ ; next three groups of lines have been conditionalized to only display
+ ; for VA agency code; also, refactored for clarity
+ ;
+ I $G(DUZ("AG"))="V" D
+ . W ! S Z=2 D WW^DGRPV
+ . W " Previous Care Date      Location of Previous Care"
+ . W !?4,"------------------      -------------------------"
+ . S DGRPX=DGRP(1010.15)
+ . ;
+ . I $P(DGRPX,"^",5)'="Y" D
+ . . S X="NONE INDICATED"
+ . . W !?4,X,?28,X
+ . ;
+ . E  F I=1:1:4 D
+ . . S I1=$P(DGRPX,"^",I)
+ . . X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)"
+ . . I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
+ ;
+ ; ** end of VOE change **
+ ;
+ W ! S Z=3 D WW^DGRPV W " Ethnicity: " D
+ .I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q
+ .N NODE,NUM,ETHNIC
+ .S I=0
+ .F NUM=0:1 S I=+$O(^DPT(DFN,.06,I)) Q:'I  D
+ ..S NODE=$G(^DPT(DFN,.06,I,0))
+ ..S X=$P($G(^DIC(10.2,+NODE,0)),"^",1)
+ ..S ETHNIC=$S(X="":"?????",1:X)
+ ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
+ ..S ETHNIC=ETHNIC_" ("_$S(X="":"?",1:X)_")"
+ ..I NUM S ETHNIC=", "_ETHNIC
+ ..I ($X+$L(ETHNIC))>IOM D  W !?15
+ ...F  S X=$P(ETHNIC," ",1)_" " Q:($X+$L(X))>IOM  W X S ETHNIC=$P(ETHNIC," ",2,999)
+ ..W ETHNIC
+ W !?9,"Race: " D
+ .I '$O(^DPT(DFN,.02,0)) W "UNANSWERED" Q
+ .N NODE,NUM,RACE
+ .S I=0
+ .F NUM=0:1 S I=+$O(^DPT(DFN,.02,I)) Q:'I  D
+ ..S NODE=$G(^DPT(DFN,.02,I,0))
+ ..S X=$P($G(^DIC(10,+NODE,0)),"^",1)
+ ..S RACE=$S(X="":"?????",1:X)
+ ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2)
+ ..S RACE=RACE_" ("_$S(X="":"?",1:X)_")"
+ ..I NUM S RACE=", "_RACE
+ ..I ($X+$L(RACE))>IOM D  W !?15
+ ...F  S X=$P(RACE," ",1)_" " Q:($X+$L(X))>IOM  W X S RACE=$P(RACE," ",2,999)
+ ..W RACE
+ D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
+ W !!
+ W "<4> Date of Death Information"
+ W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
+ W ?41,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
+ W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
+ W ?41,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
+ K PDTHINFO
+ ;
+ ;Emergency Response Indicator
+ N DGEMRES S DGEMRES=$P($G(^DPT(DFN,.18)),"^")
+ S Z=5 D WW^DGRPV W " Emergency Response: "_$$EXTERNAL^DILFD(2,.181,,DGEMRES)
+ G ^DGRPP
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP3.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP3.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP3.m	(revision 623)
@@ -1,48 +1,48 @@
-DGRP3	;ALB/MRL - REGISTRATION SCREEN 3/CONTACT INFORMATION ;11/5/06  20:31
-	;;5.3;Registration;**634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-	S DGRPW=1,DGRPS=3 D H^DGRPU F I=.21,.211,.33,.331,.34 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
-	S DGAD=.21,DGA1=3,DGA2=1 D:$P(DGRP(.21),"^",1)]"" AL^DGRPU(24) S DGAD=.211,DGA1=3,DGA2=2 D:$P(DGRP(.211),"^",1)]"" AL^DGRPU(27)
-	F DGRPI=.21,.211 S DGRPI1=$S(DGRPI=".21":"X",1:"X1") D SET
-	S Z=1 D WW^DGRPV W "      NOK: " S Z=$E($P(X,"^",1),1,22),Z1=28 D WW1^DGRPV S DGRPW=0,Z=2 D WW^DGRPV W " NOK-2: ",$E($P(X1,"^",1),1,25) D AW
-	S DGRPW=1,DGAD=.33,DGA1=3,DGA2=1 D:$P(DGRP(.33),"^",1)]"" AL^DGRPU(24) S DGAD=.331,DGA1=3,DGA2=2 D:$P(DGRP(.331),"^",1)]"" AL^DGRPU(27)
-	F DGRPI=.33,.331 S DGRPI1=$S(DGRPI=".33":"X",1:"X1") D SET
-	S Z=3 D WW^DGRPV W "  E-Cont.: " S Z=$E($P(X,"^",1),1,25),Z1=25 D WW1^DGRPV S DGRPW=0,Z=4 D WW^DGRPV W " E2-Cont.: ",$E($P(X1,"^",1),1,25) D AW
-	K DGA S DGRPW=1,DGAD=.34,DGA1=3,DGA2=1 D:$P(DGRP(.34),"^",1)]"" AL^DGRPU(24) S DGRPI=.34,DGRPI1="X" D SET S Z=5 D WW^DGRPV W " Designee: ",$E($P(X,"^",1),1,25),?50,"Relation: ",$E($P(X,"^",2),1,25)
-	F I=0:0 S I=$O(DGA(I)) Q:'I  S Z="              "_$E(DGA(I),1,27) W !,Z
-	W !?7,"Phone: ",$P(X,"^",3),?41,"Work Phone: ",$P(X,"^",4)
-	;New EHR code    ;DAOU/WCJ  2/7/05
-	;New fields for agency EHR
-	I $G(DUZ("AG"))="E" S DGRPW=0,Z=6 W ! D WW^DGRPV S DGRPI=$G(^DPT(DFN,19900)) D
-	.W "Year arrived in U.S.: ",$P(DGRPI,"^",6),!
-	.W "Mother's Country of Birth: ",$P(DGRPI,"^",4),!
-	.W "Father's Country of Birth: ",$P(DGRPI,"^",5),!
-	;End EHR modifications
-Q	K DGRPI,DGRPI1
-	G ^DGRPP
-	;
-SET	S DGRPX=DGRPU_"^"_DGRPU_"^"_DGRPU_"^"_DGRPU
-	F DGRPX1=1,2,9,11 I $P(DGRP(DGRPI),"^",DGRPX1)]"" S $P(DGRPX,"^",$S(DGRPX1=1:1,DGRPX1=2:2,DGRPX1=9:3,1:4))=$P(DGRP(DGRPI),"^",DGRPX1)
-	S @DGRPI1=DGRPX
-	K DGRPX,DGRPX1
-	Q
-AW	W !?4,"Relation: ",$E($P(X,"^",2),1,25),?43,"Relation: ",$E($P(X1,"^",2),1,25) F I=0:0 S I=$O(DGA(I)) Q:'I  S Z=$E(DGA(I),1,27) S:(I#2) Z="              "_Z W:(I#2)!($X>50) ! W:(I#2) Z I '(I#2) W ?53,Z
-	W !?7,"Phone: ",$P(X,"^",3),?46,"Phone: ",$P(X1,"^",3)
-	W !?2,"Work Phone: ",$P(X,"^",4),?41,"Work Phone: ",$P(X1,"^",4)
-	K DGA
-	Q
+DGRP3 ;ALB/MRL - REGISTRATION SCREEN 3/CONTACT INFORMATION ;11/5/06  20:31
+ ;;5.3;Registration;**634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ S DGRPW=1,DGRPS=3 D H^DGRPU F I=.21,.211,.33,.331,.34 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
+ S DGAD=.21,DGA1=3,DGA2=1 D:$P(DGRP(.21),"^",1)]"" AL^DGRPU(24) S DGAD=.211,DGA1=3,DGA2=2 D:$P(DGRP(.211),"^",1)]"" AL^DGRPU(27)
+ F DGRPI=.21,.211 S DGRPI1=$S(DGRPI=".21":"X",1:"X1") D SET
+ S Z=1 D WW^DGRPV W "      NOK: " S Z=$E($P(X,"^",1),1,22),Z1=28 D WW1^DGRPV S DGRPW=0,Z=2 D WW^DGRPV W " NOK-2: ",$E($P(X1,"^",1),1,25) D AW
+ S DGRPW=1,DGAD=.33,DGA1=3,DGA2=1 D:$P(DGRP(.33),"^",1)]"" AL^DGRPU(24) S DGAD=.331,DGA1=3,DGA2=2 D:$P(DGRP(.331),"^",1)]"" AL^DGRPU(27)
+ F DGRPI=.33,.331 S DGRPI1=$S(DGRPI=".33":"X",1:"X1") D SET
+ S Z=3 D WW^DGRPV W "  E-Cont.: " S Z=$E($P(X,"^",1),1,25),Z1=25 D WW1^DGRPV S DGRPW=0,Z=4 D WW^DGRPV W " E2-Cont.: ",$E($P(X1,"^",1),1,25) D AW
+ K DGA S DGRPW=1,DGAD=.34,DGA1=3,DGA2=1 D:$P(DGRP(.34),"^",1)]"" AL^DGRPU(24) S DGRPI=.34,DGRPI1="X" D SET S Z=5 D WW^DGRPV W " Designee: ",$E($P(X,"^",1),1,25),?50,"Relation: ",$E($P(X,"^",2),1,25)
+ F I=0:0 S I=$O(DGA(I)) Q:'I  S Z="              "_$E(DGA(I),1,27) W !,Z
+ W !?7,"Phone: ",$P(X,"^",3),?41,"Work Phone: ",$P(X,"^",4)
+ ;New EHR code    ;DAOU/WCJ  2/7/05
+ ;New fields for agency EHR
+ I $G(DUZ("AG"))="E" S DGRPW=0,Z=6 W ! D WW^DGRPV S DGRPI=$G(^DPT(DFN,19900)) D
+ .W "Year arrived in U.S.: ",$P(DGRPI,"^",6),!
+ .W "Mother's Country of Birth: ",$P(DGRPI,"^",4),!
+ .W "Father's Country of Birth: ",$P(DGRPI,"^",5),!
+ ;End EHR modifications
+Q K DGRPI,DGRPI1
+ G ^DGRPP
+ ;
+SET S DGRPX=DGRPU_"^"_DGRPU_"^"_DGRPU_"^"_DGRPU
+ F DGRPX1=1,2,9,11 I $P(DGRP(DGRPI),"^",DGRPX1)]"" S $P(DGRPX,"^",$S(DGRPX1=1:1,DGRPX1=2:2,DGRPX1=9:3,1:4))=$P(DGRP(DGRPI),"^",DGRPX1)
+ S @DGRPI1=DGRPX
+ K DGRPX,DGRPX1
+ Q
+AW W !?4,"Relation: ",$E($P(X,"^",2),1,25),?43,"Relation: ",$E($P(X1,"^",2),1,25) F I=0:0 S I=$O(DGA(I)) Q:'I  S Z=$E(DGA(I),1,27) S:(I#2) Z="              "_Z W:(I#2)!($X>50) ! W:(I#2) Z I '(I#2) W ?53,Z
+ W !?7,"Phone: ",$P(X,"^",3),?46,"Phone: ",$P(X1,"^",3)
+ W !?2,"Work Phone: ",$P(X,"^",4),?41,"Work Phone: ",$P(X1,"^",4)
+ K DGA
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m	(revision 623)
@@ -1,157 +1,157 @@
-DGRPCE	;ALB/MRL,KV,PJR,BRM - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am
-	;;5.3;Registration;**121,122,175,297,342,451,626,689,653,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-	;
-	;KV;11/15/00;DG*5.3*297;Disable addition of CD Elig Code in Reg. Screens
-	;                      ;Adding CD Elig Codes in Load/Edit Screen used to
-	;                      ;cause undefined line tag error.
-	;
-	S DGVTYN=$P($G(^DPT(DFN,"VET")),"^",1),DGDR="DR",(DR,DGD,DGDRC,DGCCF)="",DGASK=",",DGER=","_DGER D ^DGRPCE1
-	S DGEK=0 F I=9,10,11,12,13,14,18,19,20,22,24,36,51 Q:DGEK  I DGER[(","_I_",") S DGEK=1 Q
-	I 'DGKEY(1) D:DGEK ELDR S I=15 D SASK S I=23 D SASK
-	;New EHR code  DAOU/WCJ  2/5/05
-	;skip veteran related fields for agency EHR
-	G NKEY:$G(DUZ("AG"))="E"
-	;End EHR new code 
-	F I=29,30,31,32,33,43,44,45,48,56 D SASK,MON:DGCCF S DGCCF=0
-	G NKEY:DGKEY(3) F I=25,26,27,28,34,35 D SASK
-	I DGASK'[26 F I=41,42 I DGASK'[41 D SASK
-	I DGASK'[27 S I=60 I DGASK'[25 D SASK
-	I DGASK'[34 F I=37,38 I DGASK'[37 D SASK
-	I DGASK'[35 F I=39,40 I DGASK'[39 D SASK
-NKEY	D ^DGRPCE1
-	I $S(DGER[49:1,(DGER[50):1,(DGER[52):1,1:0) D
-	.I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
-	.D REG^IBCNBME(DFN)
-	.Q
-	D Q S DIE="^DPT(",(DA,Y)=DFN D ^DIE:$D(DR)
-	I DGER[54 D GETREL^DGMTU11(DFN,"SD",$$LYR^DGMTSCU1(DT)) D
-	. I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") D ASKSSN(DGREL("S"))
-	. F DGDEP=0:0 S DGDEP=$O(DGREL("D",DGDEP)) Q:'DGDEP  I $$SSN^DGMTU1(+DGREL("D",DGDEP))']"" D ASKSSN(DGREL("D",DGDEP))
-	;
-	I DGER[59 D CATDIB
-	I DGER["82" D EN2^DGRP6CL
-	;
-	K DGREL,DGDEP
-KVAR	K DR,DGEDCN,DGCT,DGER,DGINC55,DGRPADI,DGRPOUT,DGVTYN
-Q	K %,C,DA,DGASK,DGCCF,DGCT1,DGCT2,DGCT3,DGD,DGD1,DGD2,DGDR,DGDRC,DGECODE,DGEDIT,DGEK,DGKEY,DGP,DGRPADI,DGRPE,DIC,DIE,DIK,I,I1,J,X,X1,X2
-	K DGCOMLOC,DGCOMBR,FRDT,DGFRDT
-	D KVAR^VADPT
-	Q
-SASK	I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=$P($T(@I),";;",2,999),DGASK=DGASK_I_",",DGCCF=1 D SAVE
-	Q
-SAVE	I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q
-	S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
-ELDR	S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38,"
-	;Previous VA code prior to EHR changes
-	;I 'DGKEY(1) S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
-	;I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
-	;D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
-	;New code  DAOU/WCJ 2/5/05  Skip veteran specific fields
-	I 'DGKEY(1),$G(DUZ("AG"))'="E"  S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
-	I 'DGKEY(2),$G(DUZ("AG"))'="E"  F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
-	D:DGD]"" SAVE I 'DGKEY(3),$G(DUZ("AG"))'="E"  S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
-	;End new code  DAOU/WCJ  2/5/05
-	I 'DGKEY(1) D ELIG^DGRPCE1
-	Q
-MON	I $S(I<40:1,I=56:1,1:0) D SAVE Q
-	I $S(I<46:1,1:0),DGASK'[(","_(I-14)_",") D SAVE Q
-	I DGASK'[(","_(I-15)_",") D SAVE
-	Q
-	;
-15	;;.152;S:X']"" Y="@15";S DIE("NO^")="";.307;I X']"" W !!,*7,"But I need a reason why this applicant is ineligible!" S Y=.152;@15;K DIE("NO^");
-23	;;.3611;S:X'="V" Y="@23";.3612;S DIE("NO^")="";I X']"" W !!,*7,"But I need to know the date eligibility was verifed!";@23;K DIE("NO^");
-25	;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25;
-26	;;
-27	;;
-28	;;
-29	;;.36205;S:X'="Y" Y="@29";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim A&A" S Y=.36205;.36295;@29;
-30	;;.36215;S:X'="Y" Y="@30";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim HOUSEBOUND" S Y=.36215;.36295;@30;
-31	;;.36235;S:X'="Y" Y="@31";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim VA PENSION" S Y=.36235;.36295;@31;
-32	;;.36255;S:X'="Y" Y="@32";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim MIL. RET." S Y=.36255;.3625;@32;
-33	;;
-34	;;.525;S:X'="Y" Y="@34";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim POW STATUS" S Y=.525;.526:.528;@34;
-35	;;
-37	;;.525;S:X'="Y" Y="@37";.526:.528;@37;
-38	;;.525;S:X'="Y" Y="@38";.526:.528;@38;
-39	;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39;
-40	;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40;
-41	;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41;
-42	;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42;
-43	;;
-44	;;
-45	;;
-46	;;
-47	;;
-48	;;.36265;S:X'="Y" Y="@48";.3626;@48;
-51	;;I DGVTYN'="Y" S Y="@51";.324:.328;@51;
-56	;;.3025;S:X'="Y" Y="@56";.36295;@56;
-60	;;.32102;S:X'="Y" Y="@60";.32107;.3211;.32109;.3213;@60;
-	;
-	; NOTE: #46 & 47 REMOVED WITH PIMS5.3
-	;
-ASKSSN(DEP)	;edit ssns if missing
-	;
-	; input:  DEP as string for dependent (from GETREL)
-	;
-	W !,$$NAME^DGMTU1(+DEP)
-	S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
-PS	;
-	S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
-	I $$GET1^DIQ(408.13,DA_",",.09)["P" D
-	. S DR=.1,DA=$P(DA,";") D ^DIE
-	. I X']"" W !,"If SSN is a Pseudo SSN, the Pseudo SSN Reason field is required." G PS
-	K DA,DR,DIE
-	Q
-	;
-CATDIB	;
-	;Could be inconsistent because there is the catastrophic disability
-	;code without supporting information, or visa versa
-	;
-	N DGCDIS,CODE,INFO
-	S (INFO,CODE)=0
-	I $$GET^DGENCDA(DFN,.DGCDIS),DGCDIS("DATE") S INFO=1
-	S CODE=$$HASCAT^DGENCDA(DFN)
-	I CODE D  Q
-	.W !!,">>> Catastrophically Disabled eligibilty requires additional information <<<"
-	.D EDITCD^DGENCD(DFN)
-	I INFO D
-	. ;KV;11/15/00;DG*5.3*297;Start of modifications
-	. W !!,"The patient record indicates that a  determination was made "
-	. W "that the patient",!,"is catastrophically disabled."
-	. W !!,"To add Catastrophic Disability Eligibility Code(s), please use "
-	. W "the menu option",!,"DGEN PATIENT ENROLLMENT.",!!
-	.I $$ASKDEL() D
-	.. I $$DELETE^DGENCDA1(DFN) D
-	...W !,">>> Determination Deleted <<<"
-	..;
-	..;could fail if lock could not be obtained
-	..E  W !,"Catastrophic disability determination can not be deleted at this time.",!,"Please try again later."
-	;KV;11/15/00;DG*5.3*297;End of modifications
-	Q
-	;
-ASKDEL()	;
-	;ask whether to delete catastrphic disability determination
-	N DIR
-	S DIR(0)="Y"
-	;KV;11/15/00;DG*5.3*297;Cosmetic change for DIR("A")
-	S DIR("A")="Do you want to delete the determination showing that patient is catastrophically disabled"
-	S DIR("B")="YES"
-	D ^DIR
-	Q:$D(DIRUT) 0
-	Q $S(Y=1:1,1:0)
+DGRPCE ;ALB/MRL,KV,PJR,BRM - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am
+ ;;5.3;Registration;**121,122,175,297,342,451,626,689,653,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ;KV;11/15/00;DG*5.3*297;Disable addition of CD Elig Code in Reg. Screens
+ ;                      ;Adding CD Elig Codes in Load/Edit Screen used to
+ ;                      ;cause undefined line tag error.
+ ;
+ S DGVTYN=$P($G(^DPT(DFN,"VET")),"^",1),DGDR="DR",(DR,DGD,DGDRC,DGCCF)="",DGASK=",",DGER=","_DGER D ^DGRPCE1
+ S DGEK=0 F I=9,10,11,12,13,14,18,19,20,22,24,36,51 Q:DGEK  I DGER[(","_I_",") S DGEK=1 Q
+ I 'DGKEY(1) D:DGEK ELDR S I=15 D SASK S I=23 D SASK
+ ;New EHR code  DAOU/WCJ  2/5/05
+ ;skip veteran related fields for agency EHR
+ G NKEY:$G(DUZ("AG"))="E"
+ ;End EHR new code 
+ F I=29,30,31,32,33,43,44,45,48,56 D SASK,MON:DGCCF S DGCCF=0
+ G NKEY:DGKEY(3) F I=25,26,27,28,34,35 D SASK
+ I DGASK'[26 F I=41,42 I DGASK'[41 D SASK
+ I DGASK'[27 S I=60 I DGASK'[25 D SASK
+ I DGASK'[34 F I=37,38 I DGASK'[37 D SASK
+ I DGASK'[35 F I=39,40 I DGASK'[39 D SASK
+NKEY D ^DGRPCE1
+ I $S(DGER[49:1,(DGER[50):1,(DGER[52):1,1:0) D
+ .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
+ .D REG^IBCNBME(DFN)
+ .Q
+ D Q S DIE="^DPT(",(DA,Y)=DFN D ^DIE:$D(DR)
+ I DGER[54 D GETREL^DGMTU11(DFN,"SD",$$LYR^DGMTSCU1(DT)) D
+ . I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") D ASKSSN(DGREL("S"))
+ . F DGDEP=0:0 S DGDEP=$O(DGREL("D",DGDEP)) Q:'DGDEP  I $$SSN^DGMTU1(+DGREL("D",DGDEP))']"" D ASKSSN(DGREL("D",DGDEP))
+ ;
+ I DGER[59 D CATDIB
+ I DGER["82" D EN2^DGRP6CL
+ ;
+ K DGREL,DGDEP
+KVAR K DR,DGEDCN,DGCT,DGER,DGINC55,DGRPADI,DGRPOUT,DGVTYN
+Q K %,C,DA,DGASK,DGCCF,DGCT1,DGCT2,DGCT3,DGD,DGD1,DGD2,DGDR,DGDRC,DGECODE,DGEDIT,DGEK,DGKEY,DGP,DGRPADI,DGRPE,DIC,DIE,DIK,I,I1,J,X,X1,X2
+ K DGCOMLOC,DGCOMBR,FRDT,DGFRDT
+ D KVAR^VADPT
+ Q
+SASK I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=$P($T(@I),";;",2,999),DGASK=DGASK_I_",",DGCCF=1 D SAVE
+ Q
+SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q
+ S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
+ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38,"
+ ;Previous VA code prior to EHR changes
+ ;I 'DGKEY(1) S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
+ ;I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
+ ;D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
+ ;New code  DAOU/WCJ 2/5/05  Skip veteran specific fields
+ I 'DGKEY(1),$G(DUZ("AG"))'="E"  S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
+ I 'DGKEY(2),$G(DUZ("AG"))'="E"  F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
+ D:DGD]"" SAVE I 'DGKEY(3),$G(DUZ("AG"))'="E"  S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
+ ;End new code  DAOU/WCJ  2/5/05
+ I 'DGKEY(1) D ELIG^DGRPCE1
+ Q
+MON I $S(I<40:1,I=56:1,1:0) D SAVE Q
+ I $S(I<46:1,1:0),DGASK'[(","_(I-14)_",") D SAVE Q
+ I DGASK'[(","_(I-15)_",") D SAVE
+ Q
+ ;
+15 ;;.152;S:X']"" Y="@15";S DIE("NO^")="";.307;I X']"" W !!,*7,"But I need a reason why this applicant is ineligible!" S Y=.152;@15;K DIE("NO^");
+23 ;;.3611;S:X'="V" Y="@23";.3612;S DIE("NO^")="";I X']"" W !!,*7,"But I need to know the date eligibility was verifed!";@23;K DIE("NO^");
+25 ;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25;
+26 ;;
+27 ;;
+28 ;;
+29 ;;.36205;S:X'="Y" Y="@29";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim A&A" S Y=.36205;.36295;@29;
+30 ;;.36215;S:X'="Y" Y="@30";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim HOUSEBOUND" S Y=.36215;.36295;@30;
+31 ;;.36235;S:X'="Y" Y="@31";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim VA PENSION" S Y=.36235;.36295;@31;
+32 ;;.36255;S:X'="Y" Y="@32";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim MIL. RET." S Y=.36255;.3625;@32;
+33 ;;
+34 ;;.525;S:X'="Y" Y="@34";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim POW STATUS" S Y=.525;.526:.528;@34;
+35 ;;
+37 ;;.525;S:X'="Y" Y="@37";.526:.528;@37;
+38 ;;.525;S:X'="Y" Y="@38";.526:.528;@38;
+39 ;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39;
+40 ;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40;
+41 ;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41;
+42 ;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42;
+43 ;;
+44 ;;
+45 ;;
+46 ;;
+47 ;;
+48 ;;.36265;S:X'="Y" Y="@48";.3626;@48;
+51 ;;I DGVTYN'="Y" S Y="@51";.324:.328;@51;
+56 ;;.3025;S:X'="Y" Y="@56";.36295;@56;
+60 ;;.32102;S:X'="Y" Y="@60";.32107;.3211;.32109;.3213;@60;
+ ;
+ ; NOTE: #46 & 47 REMOVED WITH PIMS5.3
+ ;
+ASKSSN(DEP) ;edit ssns if missing
+ ;
+ ; input:  DEP as string for dependent (from GETREL)
+ ;
+ W !,$$NAME^DGMTU1(+DEP)
+ S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
+PS ;
+ S DA=+$P(DEP,"^",2),DIE="^DGPR(408.13,",DR=.09 D ^DIE
+ I $$GET1^DIQ(408.13,DA_",",.09)["P" D
+ . S DR=.1,DA=$P(DA,";") D ^DIE
+ . I X']"" W !,"If SSN is a Pseudo SSN, the Pseudo SSN Reason field is required." G PS
+ K DA,DR,DIE
+ Q
+ ;
+CATDIB ;
+ ;Could be inconsistent because there is the catastrophic disability
+ ;code without supporting information, or visa versa
+ ;
+ N DGCDIS,CODE,INFO
+ S (INFO,CODE)=0
+ I $$GET^DGENCDA(DFN,.DGCDIS),DGCDIS("DATE") S INFO=1
+ S CODE=$$HASCAT^DGENCDA(DFN)
+ I CODE D  Q
+ .W !!,">>> Catastrophically Disabled eligibilty requires additional information <<<"
+ .D EDITCD^DGENCD(DFN)
+ I INFO D
+ . ;KV;11/15/00;DG*5.3*297;Start of modifications
+ . W !!,"The patient record indicates that a  determination was made "
+ . W "that the patient",!,"is catastrophically disabled."
+ . W !!,"To add Catastrophic Disability Eligibility Code(s), please use "
+ . W "the menu option",!,"DGEN PATIENT ENROLLMENT.",!!
+ .I $$ASKDEL() D
+ .. I $$DELETE^DGENCDA1(DFN) D
+ ...W !,">>> Determination Deleted <<<"
+ ..;
+ ..;could fail if lock could not be obtained
+ ..E  W !,"Catastrophic disability determination can not be deleted at this time.",!,"Please try again later."
+ ;KV;11/15/00;DG*5.3*297;End of modifications
+ Q
+ ;
+ASKDEL() ;
+ ;ask whether to delete catastrphic disability determination
+ N DIR
+ S DIR(0)="Y"
+ ;KV;11/15/00;DG*5.3*297;Cosmetic change for DIR("A")
+ S DIR("A")="Do you want to delete the determination showing that patient is catastrophically disabled"
+ S DIR("B")="YES"
+ D ^DIR
+ Q:$D(DIRUT) 0
+ Q $S(Y=1:1,1:0)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPD.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPD.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPD.m	(revision 623)
@@ -1,191 +1,191 @@
-DGRPD	;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC-PATIENT INQUIRY (NEW) ;1/27/07  13:14
-	;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA
-	; GPL Copyright (C) 2007 WorldVistA
-	;  *286*  Newing variables X,Y in OKLINE subroutine
-	;  
-SEL	K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL
-	;
-EN	;call to display patient inquiry - input DFN
-	;MPI/PD CHANGE
-	S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
-	S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
-	I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^")
-	;END MPI/PD CHANGE
-	K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR F I=0,.11,.13,.121,.31,.32,.36,.361,.141,.3 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
-	S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'<DT:1,1:0) I DGTMPAD S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
-	W ?1,"Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
-	S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>50) !?10 W:'(I#2) ?51 W DGA(I)
-	S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?2,"County: ",DGCC
-	S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
-	W ?42,"From/To: ",X,!?3,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPAD
-	W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
-	W !?4,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)
-	W !?2,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)
-	W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN))
-	D CA
-	N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))
-	W:DGEMER]"" !?32,"Emergency Response: ",DGEMER
-	I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED")
-	I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED")
-	I 'DGABBRV W ! D
-	.N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
-	.K ^UTILITY($J,"W")
-	.S PTR=0 F  S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR  D
-	..S VAL=+$G(^DPT(DFN,.02,PTR,0))
-	..Q:$$INACTIVE^DGUTL4(VAL,1)
-	..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
-	..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
-	.M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
-	.K ^UTILITY($J,"W")
-	.S PTR=0 F  S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR  D
-	..S VAL=+$G(^DPT(DFN,.06,PTR,0))
-	..Q:$$INACTIVE^DGUTL4(VAL,2)
-	..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
-	..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
-	.M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
-	.K ^UTILITY($J,"W")
-	.W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
-	.F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0))  W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
-	I '$$OKLINE(16) G Q
-	;
-	; VOE change
-	;
-	I DUZ("AG")="V" D
-	. ;display cv status #4156
-	. N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
-	. W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
-	;
-	; end VOE change
-	;
-	;display primary eligibility
-	S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
-	W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I  I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X
-	I '$$OKLINE(16) G Q
-	;employability status
-	W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")
-	;display the catastrophic disability review date if there is one
-	D CATDIS^DGRPD1
-	I $G(DGPRFLG)=1 G Q:'$$OKLINE(19) D
-	. N DGPDT,DGPTM
-	. W !,$$REPEAT^XLFSTR("-",78)
-	. S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
-	. W !,"[PRE-REGISTER DATE:]  "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
-	. S DGPTM=$$PCTEAM^DGSDUTL(DFN)
-	. I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
-	. W !,$$REPEAT^XLFSTR("-",78)
-	; Check if patient is an inpatient and on a DOM ward
-	; If inpatient is on a DOM ward, don't display MT or CP messages
-	; If inpatient is NOT on a DOM ward, don't display CP message
-	N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
-	G Q:'$$OKLINE(14)
-	D DOM^DGMTR
-	I '$G(DGDOM) D
-	.D DIS^DGMTU(DFN)
-	.D IN5^VADPT
-	.I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
-	;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
-	D DIS^EASECU(DFN)   ;Added for LTC III (DG*5.3*518)
-	S VAIP("L")=""
-	I $$OKLINE(14) D INP
-	I '$G(DGRPOUT),($$OKLINE(17)) D SA
-	;MPI/PD CHANGE
-Q	D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q
-CA	;Confidential Address
-	W !!?1,"Confidential Address:  ",?44,"Confidential Address Categories:"
-	N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR
-	S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
-	I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) D  Q
-	.W !?9,"NO CONFIDENTIAL ADDRESS"
-	.W !?1,"From/To: NOT APPLICABLE"
-	S DGAD=.141,(DGA1,DGA2)=1
-	D AL^DGRPU(30)
-	D GETS^DIQ(2,DFN,".141*,","E","DGARRAY","DGERROR")
-	;Format Confidential Address categories
-	N DGIEN,DGCAST
-	S DGIEN=0
-	S DGA2=2
-	F  S DGIEN=$O(DGARRAY(2.141,DGIEN)) Q:'DGIEN  D
-	.S DGA(DGA2)=DGARRAY(2.141,DGIEN,.01,"E")
-	.S DGCAST=DGARRAY(2.141,DGIEN,1,"E")
-	.S DGA(DGA2)=DGA(DGA2)_"("_$S(DGCAST="YES":"Active",1:"Inactive")_")"
-	.S DGA2=DGA2+2
-	S I=0 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>43) !?9 W:'(I#2) ?44 W DGA(I)
-	W !?1,"From/To:  ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED")
-	Q
-HDR	I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
-	;MPI/PD CHANGE
-	; VOE CHANGE
-	; W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
-	W @IOF,!,$P(VADM(1),"^",1),?32,$P(VADM(2),"^",2),?50,$$HRNV(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
-	;END MPI/PD CHANGE
-HRNV(DFN)	;
-	N IRET
-	S IRET=$$HRN^DGLBPID(DFN)
-	I IRET="#" Q ""
-	S IRET="HRN "_IRET
-	Q IRET
-	; END VOE CHANGE
-	;
-INP	S VAIP("D")="L" D INP^DGPMV10
-	S DGPMT=0
-	D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
-SA	F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE(17) SAA Q:$G(DGRPOUT)
-	Q
-SAA	;Scheduled Admit Data
-	W !!?14,"Scheduled Admit"
-	W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
-	W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
-	W " on "_$$FMTE^XLFDT(L,"5DZ")
-	Q  ;SAA
-	;
-CL	G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I  I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")
-	;
-FA	G:'$$OKLINE(20) RMK
-	;
-	N DGARRAY,SDCNT
-	S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
-	S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "
-	;if there is lower subscripts hanging from the 101 node,
-	;then it is a valid appointment, otherwise it is
-	;an error eg 01/20/2005
-	I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK
-	I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK
-	;
-	W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
-	F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D  Q:CT>5
-	.N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")
-	.S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D
-	..D COV
-	..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
-	..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)
-	..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
-	..Q
-	I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."
-RMK	I '$G(DGRPOUT),($$OKLINE(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10)
-	D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
-	W !!
-	W "Date of Death Information"
-	W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
-	W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
-	W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
-	W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
-	I $$OKLINE(14) D EC^DGRPD1
-	K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
-	Q
-COV	S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
-	S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q
-	Q
-	;
-OREN	S XQORQUIT=1 Q:'$D(ORVP)  S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
-	Q
-OKLINE(DGLINE)	;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
-	;
-	;IN:   DGLINE --MAX LINE COUNT W/O PAUSE
-	;OUT:  DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
-	;      DGRPOUT[SET]     -- 1 IF "
-	N X,Y  ;**286** MLR 09/25/00  Newing X & Y variables prior to ^DIR
-	I $G(IOST)["P-" Q DGLINE ; if printer, quit
-	I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0
-	Q DGLINE
-	;
+DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC-PATIENT INQUIRY (NEW) ;1/27/07  13:14
+ ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA
+ ; GPL Copyright (C) 2007 WorldVistA
+ ;  *286*  Newing variables X,Y in OKLINE subroutine
+ ;  
+SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL
+ ;
+EN ;call to display patient inquiry - input DFN
+ ;MPI/PD CHANGE
+ S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
+ S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
+ I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^")
+ ;END MPI/PD CHANGE
+ K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR F I=0,.11,.13,.121,.31,.32,.36,.361,.141,.3 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
+ S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'<DT:1,1:0) I DGTMPAD S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
+ W ?1,"Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE"),?40,"Temporary: ",$S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
+ S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>50) !?10 W:'(I#2) ?51 W DGA(I)
+ S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?2,"County: ",DGCC
+ S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
+ W ?42,"From/To: ",X,!?3,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPAD
+ W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
+ W !?4,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)
+ W !?2,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)
+ W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN))
+ D CA
+ N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))
+ W:DGEMER]"" !?32,"Emergency Response: ",DGEMER
+ I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED")
+ I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED")
+ I 'DGABBRV W ! D
+ .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
+ .K ^UTILITY($J,"W")
+ .S PTR=0 F  S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR  D
+ ..S VAL=+$G(^DPT(DFN,.02,PTR,0))
+ ..Q:$$INACTIVE^DGUTL4(VAL,1)
+ ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
+ ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
+ .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
+ .K ^UTILITY($J,"W")
+ .S PTR=0 F  S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR  D
+ ..S VAL=+$G(^DPT(DFN,.06,PTR,0))
+ ..Q:$$INACTIVE^DGUTL4(VAL,2)
+ ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
+ ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
+ .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
+ .K ^UTILITY($J,"W")
+ .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
+ .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0))  W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
+ I '$$OKLINE(16) G Q
+ ;
+ ; VOE change
+ ;
+ I DUZ("AG")="V" D
+ . ;display cv status #4156
+ . N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
+ . W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
+ ;
+ ; end VOE change
+ ;
+ ;display primary eligibility
+ S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
+ W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I  I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X
+ I '$$OKLINE(16) G Q
+ ;employability status
+ W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")
+ ;display the catastrophic disability review date if there is one
+ D CATDIS^DGRPD1
+ I $G(DGPRFLG)=1 G Q:'$$OKLINE(19) D
+ . N DGPDT,DGPTM
+ . W !,$$REPEAT^XLFSTR("-",78)
+ . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
+ . W !,"[PRE-REGISTER DATE:]  "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
+ . S DGPTM=$$PCTEAM^DGSDUTL(DFN)
+ . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
+ . W !,$$REPEAT^XLFSTR("-",78)
+ ; Check if patient is an inpatient and on a DOM ward
+ ; If inpatient is on a DOM ward, don't display MT or CP messages
+ ; If inpatient is NOT on a DOM ward, don't display CP message
+ N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
+ G Q:'$$OKLINE(14)
+ D DOM^DGMTR
+ I '$G(DGDOM) D
+ .D DIS^DGMTU(DFN)
+ .D IN5^VADPT
+ .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
+ ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
+ D DIS^EASECU(DFN)   ;Added for LTC III (DG*5.3*518)
+ S VAIP("L")=""
+ I $$OKLINE(14) D INP
+ I '$G(DGRPOUT),($$OKLINE(17)) D SA
+ ;MPI/PD CHANGE
+Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q
+CA ;Confidential Address
+ W !!?1,"Confidential Address:  ",?44,"Confidential Address Categories:"
+ N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR
+ S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
+ I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) D  Q
+ .W !?9,"NO CONFIDENTIAL ADDRESS"
+ .W !?1,"From/To: NOT APPLICABLE"
+ S DGAD=.141,(DGA1,DGA2)=1
+ D AL^DGRPU(30)
+ D GETS^DIQ(2,DFN,".141*,","E","DGARRAY","DGERROR")
+ ;Format Confidential Address categories
+ N DGIEN,DGCAST
+ S DGIEN=0
+ S DGA2=2
+ F  S DGIEN=$O(DGARRAY(2.141,DGIEN)) Q:'DGIEN  D
+ .S DGA(DGA2)=DGARRAY(2.141,DGIEN,.01,"E")
+ .S DGCAST=DGARRAY(2.141,DGIEN,1,"E")
+ .S DGA(DGA2)=DGA(DGA2)_"("_$S(DGCAST="YES":"Active",1:"Inactive")_")"
+ .S DGA2=DGA2+2
+ S I=0 F I1=0:0 S I=$O(DGA(I)) Q:I=""  W:(I#2)!($X>43) !?9 W:'(I#2) ?44 W DGA(I)
+ W !?1,"From/To:  ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED")
+ Q
+HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
+ ;MPI/PD CHANGE
+ ; VOE CHANGE
+ ; W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
+ W @IOF,!,$P(VADM(1),"^",1),?32,$P(VADM(2),"^",2),?50,$$HRNV(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
+ ;END MPI/PD CHANGE
+HRNV(DFN) ;
+ N IRET
+ S IRET=$$HRN^DGLBPID(DFN)
+ I IRET="#" Q ""
+ S IRET="HRN "_IRET
+ Q IRET
+ ; END VOE CHANGE
+ ;
+INP S VAIP("D")="L" D INP^DGPMV10
+ S DGPMT=0
+ D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
+SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE(17) SAA Q:$G(DGRPOUT)
+ Q
+SAA ;Scheduled Admit Data
+ W !!?14,"Scheduled Admit"
+ W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
+ W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
+ W " on "_$$FMTE^XLFDT(L,"5DZ")
+ Q  ;SAA
+ ;
+CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I  I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")
+ ;
+FA G:'$$OKLINE(20) RMK
+ ;
+ N DGARRAY,SDCNT
+ S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
+ S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "
+ ;if there is lower subscripts hanging from the 101 node,
+ ;then it is a valid appointment, otherwise it is
+ ;an error eg 01/20/2005
+ I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK
+ I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK
+ ;
+ W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
+ F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D  Q:CT>5
+ .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")
+ .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D
+ ..D COV
+ ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
+ ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)
+ ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
+ ..Q
+ I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."
+RMK I '$G(DGRPOUT),($$OKLINE(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10)
+ D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
+ W !!
+ W "Date of Death Information"
+ W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
+ W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
+ W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
+ W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
+ I $$OKLINE(14) D EC^DGRPD1
+ K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
+ Q
+COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
+ S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q
+ Q
+ ;
+OREN S XQORQUIT=1 Q:'$D(ORVP)  S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
+ Q
+OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE
+ ;
+ ;IN:   DGLINE --MAX LINE COUNT W/O PAUSE
+ ;OUT:  DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW
+ ;      DGRPOUT[SET]     -- 1 IF "
+ N X,Y  ;**286** MLR 09/25/00  Newing X & Y variables prior to ^DIR
+ I $G(IOST)["P-" Q DGLINE ; if printer, quit
+ I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0
+ Q DGLINE
+ ;
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDB.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDB.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDB.m	(revision 623)
@@ -1,134 +1,128 @@
-DGRPDB	;ALB/AAS,JAN,ERC,PHH - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ; 3/23/06 8:16am
-	;;5.3;Registration;**26,50,358,570,631,709,713,749**;Aug 13, 1993;Build 10
-	;
-%	S:'$D(DGQUIT) DGQUIT=0
-	G:DGQUIT END S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC G:+Y<1 END S DFN=+Y D EN
-	G %
-	;
-EN	;entry with DFN defined.
-	Q:'$D(DFN)  D HOME^%ZIS,2^VADPT,HDR
-	D MT,AOIR,ELIG,DIS
-	N DGINS
-	I $$INSUR^IBBAPI(DFN,"","AR",.DGINS,1)
-	S C="",C=$O(DGINS("IBBAPI","INSUR",C),-1),C=+C+6
-	D:($Y>(IOSL-C)) PAUSE,HDR:'DGQUIT Q:DGQUIT  D INS,PAUSE
-	Q
-	;
-ELIG	;eligibility code(s)
-	W !!," Primary Elig. Code: ",$P(VAEL(1),"^",2),"  --  ",$S(VAEL(8)']"":"NOT VERIFIED",1:$P(VAEL(8),"^",2))
-	I VAEL(8)]"" S Y=$S($D(^DPT(DFN,.361)):$P(^(.361),"^",2),1:"") W "  " D DT^DIQ
-	W !,"Other Elig. Code(s): " I $D(VAEL(1))>9 S I1=0 F I=0:0 S I=$O(VAEL(1,I)) Q:'I  S I1=I1+1 W:I1>1 !?21 W $P(VAEL(1,I),"^",2)
-	E  W "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
-	Q
-	;
-DIS	;rated disabilities - Integration Agreement #700
-	;
-	;  This is called from the FEE and MCCR package!!!
-	;
-	;  Input:  DFN as IEN of PATIENT file
-	;          VAEL array (if no passed, it is set) of eligibility info
-	;
-	I '$D(VAEL) D ELIG^VADPT S DGKVAR=1
-	W:'+VAEL(3) !!,"  Service Connected: NO" W:+VAEL(3) !!,"         SC Percent: ",$P(VAEL(3),"^",2)_"%"
-	N DGQUIT
-	W !," Rated Disabilities: " I 'VAEL(4),$S('$D(^DG(391,+VAEL(6),0)):1,$P(^(0),"^",2):0,1:1) W "NOT A VETERAN" G DISQ
-	S I3=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I!($G(DGQUIT)=1)  D
-	. S I1=^(I,0),I2=$S($D(^DIC(31,+I1,0)):$P(^(0),"^",1)_" ("_+$P(I1,"^",2)_"%-"_$S($P(I1,"^",3):"SC",$P(I1,"^",3)']"":"not specified",1:"NSC")_")",1:""),I3=I3+1
-	. I $Y>(IOSL-3) D PAUSE I $G(DGQUIT)=0 W @IOF
-	. I $G(DGQUIT)=1 Q
-	. W:I3>1 !?21 W I2
-	W:'I3 "NONE STATED"
-DISQ	I $D(DGKVAR) D KVAR^VADPT K DGKVAR
-	K I,I1,I2,I3
-	Q
-	;
-INS	;insurance information
-	;
-	;  This is called form the FEE package!!!
-	;
-	;  Input:  DFN as IEN of PATIENT file
-	;          DGINSDT as date to compute insurance flag as of (default DT)
-	;
-	Q:'$D(DFN)
-	W !!,"    Health Insurance: "
-	S Z=$$INSUR^IBBAPI(DFN,$S($D(DGINSDT):DGINSDT,1:DT))
-	W $S(Z:"YES",1:"NO")
-	D DISP^DGIBDSP
-INSQ	K I,I1,DGX,Z
-	Q
-	;
-IN	; Old code
-	Q
-	;
-AOIR	;Agent Orange/ionizing radiation
-	N DGEC,NTA
-	S DGX=$S($D(^DPT(DFN,.321)):^(.321),1:"")
-	F I=2,3 S X=$P(DGX,"^",I) W:I=2 !,"           A/O Exp.: " W:I=3 "ION Rad.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED"),"   "
-	S X=$G(^DPT(DFN,.38)),X1=$P(X,"^",1) W "Medicaid Elig: ",$S(X1="":"NOT ANSWERED",'X1:"NO",1:"YES") I ($X+15)'>IOM W " - " S Y=$P(X,"^",2) D D^DIQ W $P(Y,"@")
-	S DGEC=$S($D(^DPT(DFN,.322)):^DPT(DFN,.322),1:"")
-	S X=$P(DGEC,U,13) W !,"        Env Contam.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED"),"   "
-	S NTA=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
-	K DGNTARR
-	W "N/T Radium: " W $S(NTA'="":NTA,1:"NOT ANSWERED")
-	Q
-	;
-PAUSE	F J=1:1 Q:($Y>(IOSL-3))  W !
-	S DGX1="" I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
-	Q
-	;
-HDR	;Screen Header
-	W @IOF I $P(VAEL(6),"^",2)]"" S DGTYPE=$P(VAEL(6),"^",2)
-	W $P(VADM(1),"^",1),?32,VA("PID"),?47,$P(VADM(3),"^",2) S X=$S($D(DGTYPE):$P(DGTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
-	S X="",$P(X,"=",80)="" W !,X Q
-	Q
-	;
-MT	I '$O(^DGMT(408.31,"AD",1,DFN,0)) W !,"  Means Test Status:  NOT IN MEANS TEST FILE" Q
-	;if patient is on a DOM ward, don't display Means Test required message
-	D DOM^DGMTR D:'$G(DGDOM) DIS^DGMTU(DFN) K DGDOM
-	Q
-	;
-END	D KVAR^VADPT
-	K A,C,I,I1,I2,I3,J,DIC,DIR,DFN,DGA1,DGMT,DGMTL,DGMTLA,DGX,DGX1,DGT,DGTYPE,DGQUIT,DGMTLL,X,X1,VAROOT,VA,Y,Z
-	Q
-	;
-RDIS(DGDFN,DGARR)	;API to return all Rated Disabilities from the 
-	;Patient file for a patient using an array.  Returned in descending Service Connected percent.
-	;
-	; Integration Agreement #4807
-	; 
-	;Input          DGDFN - IEN of patient file (required)
-	;Input/Output   DGARR - name of array for returned disability info (required)
-	;               piece 1 - Disability IEN (in file 31)
-	;               piece 2 - Disability %
-	;               piece 3 - SC? (1,0)
-	;               piece 4 - extremity affected
-	;               piece 5 - original effective date
-	;               piece 6 - current effective date
-	;Output 1=successful and array returned with data
-	;       0=unsuccessful and no array
-	;         
-	N DGARR1,DGC,DGCC,DGERR,DGNODE,DGCT,DGE,DGEE
-	K DGW,DGARR
-	I $G(DGDFN)']"" Q 0
-	I '$D(^DPT(DGDFN,0)) Q 0
-	D GETS^DIQ(2,DGDFN,".3721*","I","DGARR1","DGERR")
-	I $D(DGERR) Q 0
-	S DGCC=0
-	S DGCC=$O(^DPT(DGDFN,.372,DGCC))
-	I 'DGCC Q 0
-	S DGC=""
-	F  S DGC=$O(DGARR1(2.04,DGC)) Q:DGC']""  D
-	. S DGNODE=DGC
-	. S DGARR(DGC)=DGARR1(2.04,DGNODE,.01,"I")_"^"_DGARR1(2.04,DGNODE,2,"I")_"^"_DGARR1(2.04,DGNODE,3,"I")_"^"_DGARR1(2.04,DGNODE,4,"I")_"^"_DGARR1(2.04,DGNODE,5,"I")_"^"_DGARR1(2.04,DGNODE,6,"I")
-	S DGE=""
-	F  S DGE=$O(DGARR(DGE)) Q:'DGE  D
-	. I $P(DGARR(DGE),U,2)="" S $P(DGARR(DGE),U,2)=0
-	. S DGW($P(DGARR(DGE),U,2),$P(DGE,",",1))=DGARR(DGE)
-	S DGE="",DGCT=1
-	K DGARR
-	F  S DGE=$O(DGW(DGE),-1) Q:DGE']""  D
-	. F DGEE=0:0 S DGEE=$O(DGW(DGE,DGEE)) Q:DGEE'>0  D
-	. . S DGARR(DGCT)=DGW(DGE,DGEE) S DGCT=DGCT+1
-	K DGW
-	Q 1
-	;
+DGRPDB ;ALB/AAS,JAN,ERC,PHH - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ; 3/23/06 8:16am
+ ;;5.3;Registration;**26,50,358,570,631,709,713**;Aug 13, 1993
+ ;
+% S:'$D(DGQUIT) DGQUIT=0
+ G:DGQUIT END S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC G:+Y<1 END S DFN=+Y D EN
+ G %
+ ;
+EN ;entry with DFN defined.
+ Q:'$D(DFN)  D HOME^%ZIS,2^VADPT,HDR
+ D MT,AOIR,ELIG,DIS
+ N DGINS
+ I $$INSUR^IBBAPI(DFN,"","AR",.DGINS,1)
+ S C="",C=$O(DGINS("IBBAPI","INSUR",C),-1),C=+C+6
+ D:($Y>(IOSL-C)) PAUSE,HDR:'DGQUIT Q:DGQUIT  D INS,PAUSE
+ Q
+ ;
+ELIG ;eligibility code(s)
+ W !!," Primary Elig. Code: ",$P(VAEL(1),"^",2),"  --  ",$S(VAEL(8)']"":"NOT VERIFIED",1:$P(VAEL(8),"^",2))
+ I VAEL(8)]"" S Y=$S($D(^DPT(DFN,.361)):$P(^(.361),"^",2),1:"") W "  " D DT^DIQ
+ W !,"Other Elig. Code(s): " I $D(VAEL(1))>9 S I1=0 F I=0:0 S I=$O(VAEL(1,I)) Q:'I  S I1=I1+1 W:I1>1 !?21 W $P(VAEL(1,I),"^",2)
+ E  W "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
+ Q
+ ;
+DIS ;rated disabilities - Integration Agreement #700
+ ;
+ ;  This is called from the FEE and MCCR package!!!
+ ;
+ ;  Input:  DFN as IEN of PATIENT file
+ ;          VAEL array (if no passed, it is set) of eligibility info
+ ;
+ I '$D(VAEL) D ELIG^VADPT S DGKVAR=1
+ W:'+VAEL(3) !!,"  Service Connected: NO" W:+VAEL(3) !!,"         SC Percent: ",$P(VAEL(3),"^",2)_"%"
+ N DGQUIT
+ W !," Rated Disabilities: " I 'VAEL(4),$S('$D(^DG(391,+VAEL(6),0)):1,$P(^(0),"^",2):0,1:1) W "NOT A VETERAN" G DISQ
+ S I3=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I!($G(DGQUIT)=1)  D
+ . S I1=^(I,0),I2=$S($D(^DIC(31,+I1,0)):$P(^(0),"^",1)_" ("_+$P(I1,"^",2)_"%-"_$S($P(I1,"^",3):"SC",$P(I1,"^",3)']"":"not specified",1:"NSC")_")",1:""),I3=I3+1
+ . I $Y>(IOSL-3) D PAUSE I $G(DGQUIT)=0 W @IOF
+ . I $G(DGQUIT)=1 Q
+ . W:I3>1 !?21 W I2
+ W:'I3 "NONE STATED"
+DISQ I $D(DGKVAR) D KVAR^VADPT K DGKVAR
+ K I,I1,I2,I3
+ Q
+ ;
+INS ;insurance information
+ ;
+ ;  This is called form the FEE package!!!
+ ;
+ ;  Input:  DFN as IEN of PATIENT file
+ ;          DGINSDT as date to compute insurance flag as of (default DT)
+ ;
+ Q:'$D(DFN)
+ W !!,"    Health Insurance: "
+ S Z=$$INSUR^IBBAPI(DFN,$S($D(DGINSDT):DGINSDT,1:DT))
+ W $S(Z:"YES",1:"NO")
+ D DISP^DGIBDSP
+INSQ K I,I1,DGX,Z
+ Q
+ ;
+IN ; Old code
+ Q
+ ;
+AOIR ;Agent Orange/ionizing radiation
+ S DGX=$S($D(^DPT(DFN,.321)):^(.321),1:"")
+ F I=2,3 S X=$P(DGX,"^",I) W:I=2 !,"           A/O Exp.: " W:I=3 "ION Rad.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED"),"   "
+ S X=$G(^DPT(DFN,.38)),X1=$P(X,"^",1) W "Medicaid Elig: ",$S(X1="":"NOT ANSWERED",'X1:"NO",1:"YES") I ($X+15)'>IOM W " - " S Y=$P(X,"^",2) D D^DIQ W $P(Y,"@")
+ Q
+ ;
+PAUSE F J=1:1 Q:($Y>(IOSL-3))  W !
+ S DGX1="" I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
+ Q
+ ;
+HDR ;Screen Header
+ W @IOF I $P(VAEL(6),"^",2)]"" S DGTYPE=$P(VAEL(6),"^",2)
+ W $P(VADM(1),"^",1),?32,VA("PID"),?47,$P(VADM(3),"^",2) S X=$S($D(DGTYPE):$P(DGTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
+ S X="",$P(X,"=",80)="" W !,X Q
+ Q
+ ;
+MT I '$O(^DGMT(408.31,"AD",1,DFN,0)) W !,"  Means Test Status:  NOT IN MEANS TEST FILE" Q
+ ;if patient is on a DOM ward, don't display Means Test required message
+ D DOM^DGMTR D:'$G(DGDOM) DIS^DGMTU(DFN) K DGDOM
+ Q
+ ;
+END D KVAR^VADPT
+ K A,C,I,I1,I2,I3,J,DIC,DIR,DFN,DGA1,DGMT,DGMTL,DGMTLA,DGX,DGX1,DGT,DGTYPE,DGQUIT,DGMTLL,X,X1,VAROOT,VA,Y,Z
+ Q
+ ;
+RDIS(DGDFN,DGARR) ;API to return all Rated Disabilities from the 
+ ;Patient file for a patient using an array.  Returned in descending Service Connected percent.
+ ;
+ ; Integration Agreement #4807
+ ; 
+ ;Input          DGDFN - IEN of patient file (required)
+ ;Input/Output   DGARR - name of array for returned disability info (required)
+ ;               piece 1 - Disability IEN (in file 31)
+ ;               piece 2 - Disability %
+ ;               piece 3 - SC? (1,0)
+ ;               piece 4 - extremity affected
+ ;               piece 5 - original effective date
+ ;               piece 6 - current effective date
+ ;Output 1=successful and array returned with data
+ ;       0=unsuccessful and no array
+ ;         
+ N DGARR1,DGC,DGCC,DGERR,DGNODE,DGCT,DGE,DGEE
+ K DGW,DGARR
+ I $G(DGDFN)']"" Q 0
+ I '$D(^DPT(DGDFN,0)) Q 0
+ D GETS^DIQ(2,DGDFN,".3721*","I","DGARR1","DGERR")
+ I $D(DGERR) Q 0
+ S DGCC=0
+ S DGCC=$O(^DPT(DGDFN,.372,DGCC))
+ I 'DGCC Q 0
+ S DGC=""
+ F  S DGC=$O(DGARR1(2.04,DGC)) Q:DGC']""  D
+ . S DGNODE=DGC
+ . S DGARR(DGC)=DGARR1(2.04,DGNODE,.01,"I")_"^"_DGARR1(2.04,DGNODE,2,"I")_"^"_DGARR1(2.04,DGNODE,3,"I")_"^"_DGARR1(2.04,DGNODE,4,"I")_"^"_DGARR1(2.04,DGNODE,5,"I")_"^"_DGARR1(2.04,DGNODE,6,"I")
+ S DGE=""
+ F  S DGE=$O(DGARR(DGE)) Q:'DGE  D
+ . I $P(DGARR(DGE),U,2)="" S $P(DGARR(DGE),U,2)=0
+ . S DGW($P(DGARR(DGE),U,2),$P(DGE,",",1))=DGARR(DGE)
+ S DGE="",DGCT=1
+ K DGARR
+ F  S DGE=$O(DGW(DGE),-1) Q:DGE']""  D
+ . F DGEE=0:0 S DGEE=$O(DGW(DGE,DGEE)) Q:DGEE'>0  D
+ . . S DGARR(DGCT)=DGW(DGE,DGEE) S DGCT=DGCT+1
+ K DGW
+ Q 1
+ ;
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m	(revision 623)
@@ -1,160 +1,160 @@
-DGRPE	;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ;1/27/07  13:11
-	;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	;
-	; VOE changes: DAOU,VA/CJS,WV/TOAD 5/9/2006
-	; conditionally add edit fields to the following lines:
-	;    201: Is Patient a Veteran (19902), Interpreter Language (19906)
-	;    202: skip line if agency code for IHS or VOE
-	; 305002+1: for VOE, Mother's Country of Birth (19903), Father's Country
-	;         of Birth (19904), Year Arrived in U.S. (19905)
-	;
-	;DGDR contains a string of edits; edit=screen*10+item #
-	;
-	;line tag screen*10+item*1000 = continuation line
-	;
-	I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
-	I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
-	I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
-	I DGRPS=5,DGDR["501," D
-	.I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
-	.D REG^IBCNBME(DFN)
-	.Q
-	N QUIT S QUIT=0
-	I DGRPS=6,$S(DGDR["602,"!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
-	. I DGDR["601," D  Q:QUIT
-	.. D SETDR("601,",.DR)
-	.. S (DA,Y)=DFN,DIE="^DPT("
-	.. D ^DIE I $D(Y) S QUIT=1
-	.. S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
-	. I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
-	. I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
-	;-- Tricare screen #15
-	I DGRPS=15 D EDIT^DGRP15,Q Q
-	;
-	N DGPH,DGPHFLG
-	K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
-	G ^DGRPE1:DGRPS>6
-	I DGRPS=4 D ^DGRPE4
-	D SETDR(DGDR,.DR)
-	S (DA,Y)=DFN,DIE="^DPT("
-	D ^DIE
-	;check for Combat Vet status
-	I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
-	. W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
-	. S DIR(0)="EA" D ^DIR K DIR
-	I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
-Q	K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
-	Q
-	;
-SETDR(DGDR,DR)	; Set up DR string(s) for edit groups selected
-	N DGCT,DGDRS,J1,J2
-	K DR S DR="",DGDRS="DR",DGCT=0
-	F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
-	. S DGDRD=$P($T(@J1),";;",2) D S
-	. N J2
-	. F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
-	Q
-	;
-S	I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
-	S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
-	Q
-	;
-	; VOE changes at lines 201, 202, 304 & after 305002
-	;
-SETFLDS(DGDR)	; Set up fields to edit
-	Q
-	;
-101	;;
-102	;;1;
-103	;;.091;
-104	;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
-105	;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;.1211;I X']"" W !?4,$C(7),"But I need at least one line of a Temporary address." S Y=.12105;
-105000	;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^");
-109	;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
-111	;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
-111000	;;K DR(2,2.141);.1411;I X']"" W !?4,$C(7),"I need at least one line of Address." S Y=.14105;.1412;S:X']"" Y=.1414;.1413;.1414;.1415;.1416;Q;.14111;@111;K DIE("NO^");
-112	;;.134;.135;.133
-201	;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
-202	;;S:"IE"[$G(DUZ("AG")) Y="@22";1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
-203	;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
-205	;;.181;
-301	;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31;
-302	;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
-302000	;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
-303	;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34;
-303000	;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
-303001	;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35;
-303002	;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2;
-304	;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;        
-305	;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371;
-305000	;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
-305001	;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
-305002	;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
-	;;S:$G(DUZ("AG"))'="E" Y="@36";19903;19904;19905;@36401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
-401	;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
-402	;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
-501	;;
-502	;;.381;.382///NOW;
-503	;;.383;
-601	;;@60101;D SET32^DGRPE(DA,.DIPA,1);.325;S DIPA("X1")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60111";.3214;I X="" D PRF^DGRPE S Y="@60101";S Y="@6011";
-601000	;;@60111;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y);.32911;@6011;.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@60199";
-601001	;;@60102;D SET32^DGRPE(DA,.DIPA,2);.3291;S DIPA("X2")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60112";.3214;I X="" D PRF^DGRPE S Y="@60102";S Y="@6012";
-601002	;;@60112;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y);.32912;@6012;.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@60199";
-601003	;;@60103;D SET32^DGRPE(DA,.DIPA,3);.3296;S DIPA("X3")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60113";.3214;I X="" D PRF^DGRPE S Y="@60103";S Y="@6013";
-601004	;;@60113;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y);.32913;@6013;.3299;.3297;.3298;.3295;@60199;
-602	;;Q;
-603	;;Q;
-604	;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
-605	;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
-606	;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
-607	;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
-608	;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
-AD	N DGZ4,DGPC
-	S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10)
-	I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4
-	K DGADD,DGPHONE Q
-DR109	;Drop through (use same logic as DR203)
-DR203	S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;"
-	S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;"
-	Q
-DR111	;Set DR string for Confidential Address categories
-	S DR(2,2.141)=".01;1//YES;"
-	Q
-PRF	; Write Proof needed for FV
-	W !?4,$C(7),"Proof is required for Filipino vet."
-	Q
-	;
-SET32(DA,DIPA,SEQ)	; Extract the .32 node from patient file and set DIPA
-	; array with the BOS and component data for the SEQ military service
-	; episode (1-3)
-	N I,Q,Z
-	K DIPA(32,SEQ)
-	S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
-	S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U)
-	Q
-	;
-WARN32(X,DIPA,SEQ,Y)	; Warn if the BOS is changed, then the component will
-	; be deleted
-	; Returns Y to skip component if the component should not be asked
-	;   for this branch of service
-	N Z
-	I '$$CMP(X) S Y="@601"_SEQ
-	S Z=$G(DIPA(32,SEQ))
-	Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
-	;
-	I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
-	Q
-	;
-CMP(X)	; Function to determine if service component is valid for
-	; branch of service ien in X   0 = invalid  1 = valid  
-	; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
-	Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
-	;
+DGRPE ;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ;1/27/07  13:11
+ ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ;
+ ; VOE changes: DAOU,VA/CJS,WV/TOAD 5/9/2006
+ ; conditionally add edit fields to the following lines:
+ ;    201: Is Patient a Veteran (19902), Interpreter Language (19906)
+ ;    202: skip line if agency code for IHS or VOE
+ ; 305002+1: for VOE, Mother's Country of Birth (19903), Father's Country
+ ;         of Birth (19904), Year Arrived in U.S. (19905)
+ ;
+ ;DGDR contains a string of edits; edit=screen*10+item #
+ ;
+ ;line tag screen*10+item*1000 = continuation line
+ ;
+ I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
+ I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
+ I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
+ I DGRPS=5,DGDR["501," D
+ .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
+ .D REG^IBCNBME(DFN)
+ .Q
+ N QUIT S QUIT=0
+ I DGRPS=6,$S(DGDR["602,"!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
+ . I DGDR["601," D  Q:QUIT
+ .. D SETDR("601,",.DR)
+ .. S (DA,Y)=DFN,DIE="^DPT("
+ .. D ^DIE I $D(Y) S QUIT=1
+ .. S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
+ . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
+ . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
+ ;-- Tricare screen #15
+ I DGRPS=15 D EDIT^DGRP15,Q Q
+ ;
+ N DGPH,DGPHFLG
+ K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
+ G ^DGRPE1:DGRPS>6
+ I DGRPS=4 D ^DGRPE4
+ D SETDR(DGDR,.DR)
+ S (DA,Y)=DFN,DIE="^DPT("
+ D ^DIE
+ ;check for Combat Vet status
+ I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
+ . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
+ . S DIR(0)="EA" D ^DIR K DIR
+ I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
+Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
+ Q
+ ;
+SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected
+ N DGCT,DGDRS,J1,J2
+ K DR S DR="",DGDRS="DR",DGCT=0
+ F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
+ . S DGDRD=$P($T(@J1),";;",2) D S
+ . N J2
+ . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
+ Q
+ ;
+S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
+ S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
+ Q
+ ;
+ ; VOE changes at lines 201, 202, 304 & after 305002
+ ;
+SETFLDS(DGDR) ; Set up fields to edit
+ Q
+ ;
+101 ;;
+102 ;;1;
+103 ;;.091;
+104 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
+105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;.1211;I X']"" W !?4,$C(7),"But I need at least one line of a Temporary address." S Y=.12105;
+105000 ;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^");
+109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
+111 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
+111000 ;;K DR(2,2.141);.1411;I X']"" W !?4,$C(7),"I need at least one line of Address." S Y=.14105;.1412;S:X']"" Y=.1414;.1413;.1414;.1415;.1416;Q;.14111;@111;K DIE("NO^");
+112 ;;.134;.135;.133
+201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
+202 ;;S:"IE"[$G(DUZ("AG")) Y="@22";1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
+203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
+205 ;;.181;
+301 ;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31;
+302 ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
+302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
+303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34;
+303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
+303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35;
+303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2;
+304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;        
+305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371;
+305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
+305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
+305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
+ ;;S:$G(DUZ("AG"))'="E" Y="@36";19903;19904;19905;@36401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
+401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
+402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
+501 ;;
+502 ;;.381;.382///NOW;
+503 ;;.383;
+601 ;;@60101;D SET32^DGRPE(DA,.DIPA,1);.325;S DIPA("X1")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60111";.3214;I X="" D PRF^DGRPE S Y="@60101";S Y="@6011";
+601000 ;;@60111;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y);.32911;@6011;.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@60199";
+601001 ;;@60102;D SET32^DGRPE(DA,.DIPA,2);.3291;S DIPA("X2")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60112";.3214;I X="" D PRF^DGRPE S Y="@60102";S Y="@6012";
+601002 ;;@60112;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y);.32912;@6012;.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@60199";
+601003 ;;@60103;D SET32^DGRPE(DA,.DIPA,3);.3296;S DIPA("X3")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60113";.3214;I X="" D PRF^DGRPE S Y="@60103";S Y="@6013";
+601004 ;;@60113;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y);.32913;@6013;.3299;.3297;.3298;.3295;@60199;
+602 ;;Q;
+603 ;;Q;
+604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
+605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
+606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
+607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
+608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
+AD N DGZ4,DGPC
+ S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10)
+ I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4
+ K DGADD,DGPHONE Q
+DR109 ;Drop through (use same logic as DR203)
+DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;"
+ S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;"
+ Q
+DR111 ;Set DR string for Confidential Address categories
+ S DR(2,2.141)=".01;1//YES;"
+ Q
+PRF ; Write Proof needed for FV
+ W !?4,$C(7),"Proof is required for Filipino vet."
+ Q
+ ;
+SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA
+ ; array with the BOS and component data for the SEQ military service
+ ; episode (1-3)
+ N I,Q,Z
+ K DIPA(32,SEQ)
+ S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
+ S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U)
+ Q
+ ;
+WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will
+ ; be deleted
+ ; Returns Y to skip component if the component should not be asked
+ ;   for this branch of service
+ N Z
+ I '$$CMP(X) S Y="@601"_SEQ
+ S Z=$G(DIPA(32,SEQ))
+ Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
+ ;
+ I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
+ Q
+ ;
+CMP(X) ; Function to determine if service component is valid for
+ ; branch of service ien in X   0 = invalid  1 = valid  
+ ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
+ Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
+ ;
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m	(revision 623)
@@ -1,216 +1,216 @@
-DGRPECE	;ALB/MRY - REGISTRATION CATASTROPHIC EDITS ;1/6/07  13:28
-	;;5.3;Registration;**638,682,700,720,653,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-	;
-CEDITS(DFN)	;catastrophic edits  - buffer values, save after check
-	;Input;
-	;  DFN  := patient ien
-	;Catastrophic edits will prompt for name, ssn, dob, and sex.  Placing
-	;responses into a buffer space.  User will be alerted on catastrophic
-	;edits on the following conditions:
-	; 1. Two or more catastrophic edits will generate a warning message.
-	; 2. Acceptance of two or more catastrophic edits will generate an alert
-	; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key.
-	; 3. Acceptance of <2 catastrophic edits will process normally.
-	;
-	; Arrays: BEFORE - Holds patient values before the edit process
-	;                  (before snapshot).
-	;         BUFFER - initialized with BEFORE array, holds edited changes
-	;                  (after snapshot).
-	;         SAVE   - holds only edited changes for filing into file #2.
-	;
-	N DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN
-	D BEFORE(DFN,.BEFORE,.BUFFER) ;retrieve before patient values
-	;buffer - get name
-	K DG20NAME
-	S BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME)
-	I BUFFER("NAME")="" S BUFFER("NAME")=BEFORE("NAME")
-	I $D(DG20NAME("FAMILY")) S BUFFER("FAMILY")=DG20NAME("FAMILY")
-	I $D(DG20NAME("GIVEN")) S BUFFER("GIVEN")=DG20NAME("GIVEN")
-	I $D(DG20NAME("MIDDLE")) S BUFFER("MIDDLE")=DG20NAME("MIDDLE")
-	I $D(DG20NAME("SUFFIX")) S BUFFER("SUFFIX")=DG20NAME("SUFFIX")
-	; the formal name is last name, first name, middle name and suffix
-	; the prefix and degree are only stored in file 20
-	I $D(DG20NAME("PREFIX")) S BUFFER("PREFIX")=DG20NAME("PREFIX")
-	I $D(DG20NAME("DEGREE")) S BUFFER("DEGREE")=DG20NAME("DEGREE")
-	K DG20NAME
-	;buffer - get ssn
-	S DIR(0)="2,.09^^"
-	S DA=DFN D ^DIR
-	I $D(DIRUT),DUZ("AG")="V" D CECHECK Q  ; VOE modification, SSN may be null
-	I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
-	S BUFFER("SSN")=Y
-	;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC
-	I $G(BUFFER("SSN"))["P" D  I $D(DIRUT) D CECHECK Q
-REAS	. ;
-	. N DGREA,DGQSSN,DIR
-	. S DGQSSN=0
-	. S DGREA=$P($G(^DPT(DFN,"SSN")),U)
-	. S DIR(0)="2,.0906^^"
-	. S DA=DFN
-	. D ^DIR
-	. I ($D(DUOUT)!($D(DTOUT))!($D(DIRUT))),($G(BUFFER("SSNREAS"))']"") D
-	. . W !?10,"PSSN Reason Required if SSN is a Pseudo."
-	. . I $G(BEFORE("SSN"))["P" G REAS
-	. . I $G(BEFORE("SSN"))']"" G REAS
-	. . S DIR(0)="YA",DIR("A")="          Delete Pseudo SSN?: ",DIR("?")="If the SSN is a Pseudo SSN there must be a Pseudo SSN Reason.",DIR("B")="YES"
-	. . D ^DIR
-	. . I Y=1 S BUFFER("SSN")=BEFORE("SSN"),DGQSSN=1,Y="" Q
-	. . G REAS
-	. I DGQSSN=1 Q
-	. S BUFFER("SSNREAS")=Y
-	. I $D(DIRUT)!('$D(BUFFER("SSN"))) D CECHECK Q
-DOB	;buffer - get dob
-	S DIR(0)="2,.03^^"
-	S DA=DFN D ^DIR
-	I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
-	I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
-	S BUFFER("DOB")=Y
-SEX	;buffer - get sex
-	S DIR(0)="2,.02^^"
-	S DA=DFN D ^DIR
-	I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
-	I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
-	S BUFFER("SEX")=Y
-MBI	; buffer - get MBI (multiple birth indicator)
-	S DIR(0)="2,994^^"
-	S DA=DFN D ^DIR
-	S BUFFER("MBI")=Y
-	I $D(DIRUT) D CECHECK Q
-CECHECK	;do catastrophic edit checks, alert, and save
-	N DGCNT,DGCEFLG
-	;Compare before/buffer arrays, putting edits into save array.
-	S DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE)
-	;   DGCNT:  0  = no changes
-	;           1  = only one edit change, ok to save w/o CE message
-	;           >1 = more then 1 edit, give CE message
-	I DGCNT>1 D  ;give CE message
-	. S DGCEFLG=$$WARNING()
-	. ;    DGCEFLG: 0  = exit without saving changes
-	. ;             1  = send alert and save
-	. I DGCEFLG=0 S DGCNT=0
-	I DGCNT>0 D SAVE(DFN) I $D(DGCEFLG),DGCEFLG D ALERT
-	Q
-	;
-SAVE(DFN)	;store accepted/edited values into patient file
-	N FDATA,DIERR
-	I $D(SAVE("NAME")) S FDATA(2,+DFN_",",.01)=SAVE("NAME")
-	I $D(SAVE("DOB")) S FDATA(2,+DFN_",",.03)=SAVE("DOB")
-	I $D(SAVE("SEX")) S FDATA(2,+DFN_",",.02)=SAVE("SEX")
-	I $D(SAVE("SSN")) S FDATA(2,+DFN_",",.09)=SAVE("SSN")
-	I $D(SAVE("SSNREAS")) S FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS")
-	I $D(SAVE("MBI")) S FDATA(2,+DFN_",",994)=SAVE("MBI")
-	D FILE^DIE("","FDATA","DIERR")
-	K FDATA,DIERR
-	I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I")
-	I $D(SAVE("NAME")) D
-	.S FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY")
-	.S FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN")
-	.S FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE")
-	.S FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX")
-	.D FILE^DIE("","FDATA","DIERR")
-	.K FDATA,DIERR
-	I $D(BUFFER("PREFIX")) S FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX")
-	I $D(BUFFER("DEGREE")) S FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE")
-	I $D(SAVE("PREFIX")) S FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX")
-	I $D(SAVE("DEGREE")) S FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE")
-	D FILE^DIE("","FDATA","DIERR")
-	K FDATA,DIERR
-	Q
-	;
-BEFORE(IEN,BEF,BUF)	;save original name, ssn, dob, sex, mbi, prefix, degree
-	N DG20
-	S BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01),BUF("NAME")=BEF("NAME")
-	S BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09),BUF("SSN")=BEF("SSN")
-	S BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906),BUF("SSNREAS")=BEF("SSNREAS")
-	S BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I"),BUF("DOB")=BEF("DOB")
-	S BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I"),BUF("SEX")=BEF("SEX")
-	S BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I"),BUF("MBI")=BEF("MBI")
-	D GETS^DIQ(2,+IEN_",",1.01,"I","DG20")
-	S BEF("FAMILY")="",BEF("GIVEN")="",BUF("FAMILY")="",BUF("GIVEN")=""
-	S BEF("MIDDLE")="",BEF("SUFFIX")="",BUF("MIDDLE")="",BUF("SUFFIX")=""
-	S BEF("PREFIX")="",BEF("DEGREE")="",BUF("PREFIX")="",BUF("DEGREE")=""
-	S DG20IEN=DG20(2,+IEN_",",1.01,"I")
-	I $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN D
-	. S BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1),BUF("FAMILY")=BEF("FAMILY")
-	. S BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2),BUF("GIVEN")=BEF("GIVEN")
-	. S BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3),BUF("MIDDLE")=BEF("MIDDLE")
-	. S BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5),BUF("SUFFIX")=BEF("SUFFIX")
-	. S BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4),BUF("PREFIX")=BEF("PREFIX")
-	. S BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6),BUF("DEGREE")=BEF("DEGREE")
-	;add some demographic information (before snapshot)
-	S BEF("MAIDEN")=$E($$GET1^DIQ(2,+IEN_",",.2403),1,17)
-	S BEF("POBCITY")=$E($$GET1^DIQ(2,+IEN_",",.092),1,15)
-	S BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I")
-	Q
-	;
-AFTER(BEF,BUF,SAV)	;prevent catastrophic edit checks
-	N DGCNT,DG20CNT S (DGCNT,DG20CNT)=0
-	I $D(BUF("FAMILY")),BUF("FAMILY")'="",BUF("FAMILY")'=BEF("FAMILY") D
-	. S DG20CNT=DG20CNT+1
-	. S SAV("NAME")=BUF("NAME")
-	I $D(BUF("GIVEN")),BUF("GIVEN")'="",BUF("GIVEN")'=BEF("GIVEN") D
-	. S DG20CNT=DG20CNT+1
-	. S SAV("NAME")=BUF("NAME")
-	I $D(BUF("MIDDLE")),BUF("MIDDLE")'=BEF("MIDDLE") D
-	. S SAV("NAME")=BUF("NAME") ; minor change doesn't count
-	I $D(BUF("SUFFIX")),BUF("SUFFIX")'=BEF("SUFFIX") D
-	. S SAV("NAME")=BUF("NAME") ; minor change doesn't count
-	I DG20CNT>0 S DGCNT=1
-	I $D(BUF("PREFIX")),BUF("PREFIX")'=BEF("PREFIX") D
-	. S SAV("PREFIX")=BUF("PREFIX")
-	I $D(BUF("DEGREE")),BUF("DEGREE")'=BEF("DEGREE") D
-	. S SAV("DEGREE")=BUF("DEGREE")
-	I $D(BUF("DOB")),BUF("DOB")'="",BUF("DOB")'=BEF("DOB") D
-	. S SAV("DOB")=BUF("DOB"),DGCNT=DGCNT+1
-	I $D(BUF("SEX")),BUF("SEX")'="",BUF("SEX")'=BEF("SEX") D
-	. S SAV("SEX")=BUF("SEX"),DGCNT=DGCNT+1
-	I $D(BUF("SSN")),BUF("SSN")'="",BUF("SSN")'=BEF("SSN") D
-	. S SAV("SSN")=BUF("SSN"),DGCNT=DGCNT+1
-	I $D(BUF("SSNREAS")),BUF("SSNREAS")'="",BUF("SSNREAS")'=BEF("SSNREAS") D
-	. S SAV("SSNREAS")=BUF("SSNREAS"),DGCNT=DGCNT+1
-	I $D(BUF("MBI")),BUF("MBI")'=BEF("MBI") D
-	. S SAV("MBI")=BUF("MBI")
-	I DGCNT=0,$D(SAV("NAME")) Q 1 ;minor name change (i.e. middle name or suffix)
-	I DGCNT=0,$D(SAV("PREFIX"))!($D(SAV("DEGREE"))) Q 1 ; prefix or degree change
-	I DGCNT=0,$D(SAV("MBI")) Q 1 ; multiple birth indicator change
-	I DGCNT=0 Q 0 ;no changes
-	I DGCNT<2 Q 1 ;make one change w/o CE message
-	I DGCNT>1 Q 2 ;more than 1 change, send CE message
-	;
-WARNING()	;CE warning message
-	;Output     0  = exit without saving changes
-	;           1  = send alert and save
-	W !!,?25,"**WARNING!!**"
-	W !!,"The edits you are about to make, may potentially change the identity of"
-	W !,"this patient.  Please verify that you have selected the correct patient"
-	W !,"and ensure that supporting documentation exists for these changes.  If"
-	W !,"you continue with these edits, an alert will be generated and sent to"
-	W !,"your Supervisor and ADPAC, notifying them of the changes."
-	N DIR,DGANS,Y
-	S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits:"
-	S DIR("B")="NO" D ^DIR K DIR S DGANS=Y
-	S DGANS=$S(Y=1:1,1:0) ;0=don't save, 1=save with CE alert
-	Q DGANS
-	;
-ALERT	;Queue alert
-	X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ALERT^DGRPECE1",ZTDTH=$H,ZTIO="",IEN=DFN
-	F V="IEN","BEFORE(","BUFFER(","SAVE(","XQY" S ZTSAVE(V)=""
-	S ZTDESC="Patient Catastrophic Edits alert" K V,ZTSK N X D ^%ZTLOAD  Q
-	;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE)
-	Q
+DGRPECE ;ALB/MRY - REGISTRATION CATASTROPHIC EDITS ;1/6/07  13:28
+ ;;5.3;Registration;**638,682,700,720,653,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+CEDITS(DFN) ;catastrophic edits  - buffer values, save after check
+ ;Input;
+ ;  DFN  := patient ien
+ ;Catastrophic edits will prompt for name, ssn, dob, and sex.  Placing
+ ;responses into a buffer space.  User will be alerted on catastrophic
+ ;edits on the following conditions:
+ ; 1. Two or more catastrophic edits will generate a warning message.
+ ; 2. Acceptance of two or more catastrophic edits will generate an alert
+ ; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key.
+ ; 3. Acceptance of <2 catastrophic edits will process normally.
+ ;
+ ; Arrays: BEFORE - Holds patient values before the edit process
+ ;                  (before snapshot).
+ ;         BUFFER - initialized with BEFORE array, holds edited changes
+ ;                  (after snapshot).
+ ;         SAVE   - holds only edited changes for filing into file #2.
+ ;
+ N DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN
+ D BEFORE(DFN,.BEFORE,.BUFFER) ;retrieve before patient values
+ ;buffer - get name
+ K DG20NAME
+ S BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME)
+ I BUFFER("NAME")="" S BUFFER("NAME")=BEFORE("NAME")
+ I $D(DG20NAME("FAMILY")) S BUFFER("FAMILY")=DG20NAME("FAMILY")
+ I $D(DG20NAME("GIVEN")) S BUFFER("GIVEN")=DG20NAME("GIVEN")
+ I $D(DG20NAME("MIDDLE")) S BUFFER("MIDDLE")=DG20NAME("MIDDLE")
+ I $D(DG20NAME("SUFFIX")) S BUFFER("SUFFIX")=DG20NAME("SUFFIX")
+ ; the formal name is last name, first name, middle name and suffix
+ ; the prefix and degree are only stored in file 20
+ I $D(DG20NAME("PREFIX")) S BUFFER("PREFIX")=DG20NAME("PREFIX")
+ I $D(DG20NAME("DEGREE")) S BUFFER("DEGREE")=DG20NAME("DEGREE")
+ K DG20NAME
+ ;buffer - get ssn
+ S DIR(0)="2,.09^^"
+ S DA=DFN D ^DIR
+ I $D(DIRUT),DUZ("AG")="V" D CECHECK Q  ; VOE modification, SSN may be null
+ I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
+ S BUFFER("SSN")=Y
+ ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC
+ I $G(BUFFER("SSN"))["P" D  I $D(DIRUT) D CECHECK Q
+REAS . ;
+ . N DGREA,DGQSSN,DIR
+ . S DGQSSN=0
+ . S DGREA=$P($G(^DPT(DFN,"SSN")),U)
+ . S DIR(0)="2,.0906^^"
+ . S DA=DFN
+ . D ^DIR
+ . I ($D(DUOUT)!($D(DTOUT))!($D(DIRUT))),($G(BUFFER("SSNREAS"))']"") D
+ . . W !?10,"PSSN Reason Required if SSN is a Pseudo."
+ . . I $G(BEFORE("SSN"))["P" G REAS
+ . . I $G(BEFORE("SSN"))']"" G REAS
+ . . S DIR(0)="YA",DIR("A")="          Delete Pseudo SSN?: ",DIR("?")="If the SSN is a Pseudo SSN there must be a Pseudo SSN Reason.",DIR("B")="YES"
+ . . D ^DIR
+ . . I Y=1 S BUFFER("SSN")=BEFORE("SSN"),DGQSSN=1,Y="" Q
+ . . G REAS
+ . I DGQSSN=1 Q
+ . S BUFFER("SSNREAS")=Y
+ . I $D(DIRUT)!('$D(BUFFER("SSN"))) D CECHECK Q
+DOB ;buffer - get dob
+ S DIR(0)="2,.03^^"
+ S DA=DFN D ^DIR
+ I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
+ I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
+ S BUFFER("DOB")=Y
+SEX ;buffer - get sex
+ S DIR(0)="2,.02^^"
+ S DA=DFN D ^DIR
+ I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
+ I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
+ S BUFFER("SEX")=Y
+MBI ; buffer - get MBI (multiple birth indicator)
+ S DIR(0)="2,994^^"
+ S DA=DFN D ^DIR
+ S BUFFER("MBI")=Y
+ I $D(DIRUT) D CECHECK Q
+CECHECK ;do catastrophic edit checks, alert, and save
+ N DGCNT,DGCEFLG
+ ;Compare before/buffer arrays, putting edits into save array.
+ S DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE)
+ ;   DGCNT:  0  = no changes
+ ;           1  = only one edit change, ok to save w/o CE message
+ ;           >1 = more then 1 edit, give CE message
+ I DGCNT>1 D  ;give CE message
+ . S DGCEFLG=$$WARNING()
+ . ;    DGCEFLG: 0  = exit without saving changes
+ . ;             1  = send alert and save
+ . I DGCEFLG=0 S DGCNT=0
+ I DGCNT>0 D SAVE(DFN) I $D(DGCEFLG),DGCEFLG D ALERT
+ Q
+ ;
+SAVE(DFN) ;store accepted/edited values into patient file
+ N FDATA,DIERR
+ I $D(SAVE("NAME")) S FDATA(2,+DFN_",",.01)=SAVE("NAME")
+ I $D(SAVE("DOB")) S FDATA(2,+DFN_",",.03)=SAVE("DOB")
+ I $D(SAVE("SEX")) S FDATA(2,+DFN_",",.02)=SAVE("SEX")
+ I $D(SAVE("SSN")) S FDATA(2,+DFN_",",.09)=SAVE("SSN")
+ I $D(SAVE("SSNREAS")) S FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS")
+ I $D(SAVE("MBI")) S FDATA(2,+DFN_",",994)=SAVE("MBI")
+ D FILE^DIE("","FDATA","DIERR")
+ K FDATA,DIERR
+ I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I")
+ I $D(SAVE("NAME")) D
+ .S FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY")
+ .S FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN")
+ .S FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE")
+ .S FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX")
+ .D FILE^DIE("","FDATA","DIERR")
+ .K FDATA,DIERR
+ I $D(BUFFER("PREFIX")) S FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX")
+ I $D(BUFFER("DEGREE")) S FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE")
+ I $D(SAVE("PREFIX")) S FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX")
+ I $D(SAVE("DEGREE")) S FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE")
+ D FILE^DIE("","FDATA","DIERR")
+ K FDATA,DIERR
+ Q
+ ;
+BEFORE(IEN,BEF,BUF) ;save original name, ssn, dob, sex, mbi, prefix, degree
+ N DG20
+ S BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01),BUF("NAME")=BEF("NAME")
+ S BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09),BUF("SSN")=BEF("SSN")
+ S BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906),BUF("SSNREAS")=BEF("SSNREAS")
+ S BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I"),BUF("DOB")=BEF("DOB")
+ S BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I"),BUF("SEX")=BEF("SEX")
+ S BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I"),BUF("MBI")=BEF("MBI")
+ D GETS^DIQ(2,+IEN_",",1.01,"I","DG20")
+ S BEF("FAMILY")="",BEF("GIVEN")="",BUF("FAMILY")="",BUF("GIVEN")=""
+ S BEF("MIDDLE")="",BEF("SUFFIX")="",BUF("MIDDLE")="",BUF("SUFFIX")=""
+ S BEF("PREFIX")="",BEF("DEGREE")="",BUF("PREFIX")="",BUF("DEGREE")=""
+ S DG20IEN=DG20(2,+IEN_",",1.01,"I")
+ I $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN D
+ . S BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1),BUF("FAMILY")=BEF("FAMILY")
+ . S BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2),BUF("GIVEN")=BEF("GIVEN")
+ . S BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3),BUF("MIDDLE")=BEF("MIDDLE")
+ . S BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5),BUF("SUFFIX")=BEF("SUFFIX")
+ . S BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4),BUF("PREFIX")=BEF("PREFIX")
+ . S BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6),BUF("DEGREE")=BEF("DEGREE")
+ ;add some demographic information (before snapshot)
+ S BEF("MAIDEN")=$E($$GET1^DIQ(2,+IEN_",",.2403),1,17)
+ S BEF("POBCITY")=$E($$GET1^DIQ(2,+IEN_",",.092),1,15)
+ S BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I")
+ Q
+ ;
+AFTER(BEF,BUF,SAV) ;prevent catastrophic edit checks
+ N DGCNT,DG20CNT S (DGCNT,DG20CNT)=0
+ I $D(BUF("FAMILY")),BUF("FAMILY")'="",BUF("FAMILY")'=BEF("FAMILY") D
+ . S DG20CNT=DG20CNT+1
+ . S SAV("NAME")=BUF("NAME")
+ I $D(BUF("GIVEN")),BUF("GIVEN")'="",BUF("GIVEN")'=BEF("GIVEN") D
+ . S DG20CNT=DG20CNT+1
+ . S SAV("NAME")=BUF("NAME")
+ I $D(BUF("MIDDLE")),BUF("MIDDLE")'=BEF("MIDDLE") D
+ . S SAV("NAME")=BUF("NAME") ; minor change doesn't count
+ I $D(BUF("SUFFIX")),BUF("SUFFIX")'=BEF("SUFFIX") D
+ . S SAV("NAME")=BUF("NAME") ; minor change doesn't count
+ I DG20CNT>0 S DGCNT=1
+ I $D(BUF("PREFIX")),BUF("PREFIX")'=BEF("PREFIX") D
+ . S SAV("PREFIX")=BUF("PREFIX")
+ I $D(BUF("DEGREE")),BUF("DEGREE")'=BEF("DEGREE") D
+ . S SAV("DEGREE")=BUF("DEGREE")
+ I $D(BUF("DOB")),BUF("DOB")'="",BUF("DOB")'=BEF("DOB") D
+ . S SAV("DOB")=BUF("DOB"),DGCNT=DGCNT+1
+ I $D(BUF("SEX")),BUF("SEX")'="",BUF("SEX")'=BEF("SEX") D
+ . S SAV("SEX")=BUF("SEX"),DGCNT=DGCNT+1
+ I $D(BUF("SSN")),BUF("SSN")'="",BUF("SSN")'=BEF("SSN") D
+ . S SAV("SSN")=BUF("SSN"),DGCNT=DGCNT+1
+ I $D(BUF("SSNREAS")),BUF("SSNREAS")'="",BUF("SSNREAS")'=BEF("SSNREAS") D
+ . S SAV("SSNREAS")=BUF("SSNREAS"),DGCNT=DGCNT+1
+ I $D(BUF("MBI")),BUF("MBI")'=BEF("MBI") D
+ . S SAV("MBI")=BUF("MBI")
+ I DGCNT=0,$D(SAV("NAME")) Q 1 ;minor name change (i.e. middle name or suffix)
+ I DGCNT=0,$D(SAV("PREFIX"))!($D(SAV("DEGREE"))) Q 1 ; prefix or degree change
+ I DGCNT=0,$D(SAV("MBI")) Q 1 ; multiple birth indicator change
+ I DGCNT=0 Q 0 ;no changes
+ I DGCNT<2 Q 1 ;make one change w/o CE message
+ I DGCNT>1 Q 2 ;more than 1 change, send CE message
+ ;
+WARNING() ;CE warning message
+ ;Output     0  = exit without saving changes
+ ;           1  = send alert and save
+ W !!,?25,"**WARNING!!**"
+ W !!,"The edits you are about to make, may potentially change the identity of"
+ W !,"this patient.  Please verify that you have selected the correct patient"
+ W !,"and ensure that supporting documentation exists for these changes.  If"
+ W !,"you continue with these edits, an alert will be generated and sent to"
+ W !,"your Supervisor and ADPAC, notifying them of the changes."
+ N DIR,DGANS,Y
+ S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits:"
+ S DIR("B")="NO" D ^DIR K DIR S DGANS=Y
+ S DGANS=$S(Y=1:1,1:0) ;0=don't save, 1=save with CE alert
+ Q DGANS
+ ;
+ALERT ;Queue alert
+ X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ALERT^DGRPECE1",ZTDTH=$H,ZTIO="",IEN=DFN
+ F V="IEN","BEFORE(","BUFFER(","SAVE(","XQY" S ZTSAVE(V)=""
+ S ZTDESC="Patient Catastrophic Edits alert" K V,ZTSK N X D ^%ZTLOAD  Q
+ ;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE)
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX.m	(revision 623)
@@ -1,7 +1,7 @@
-DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TEMPLATE(#1476), FILE 2;12/13/08
+DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TEMPLATE(#1476), FILE 2;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
  I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(3)=%
- I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(7)=% S %=$P(%Z,U,2) S:%]"" DE(9)=% S %=$P(%Z,U,3) S:%]"" DE(11)=%
+ I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(7)=% S %=$P(%Z,U,2) S:%]"" DE(9)=%
  I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(4)=%
  I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(5)=%
@@ -94,5 +94,5 @@
 C3F1 Q
 X3 Q
-4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391
+4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391
  S DE(DW)="C4^DGRPTX",DE(DW,"INDEX")=1
  S DU="DG(391,"
@@ -118,5 +118,5 @@
 C4F2 Q
 X4 Q
-5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
+5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
  S DE(DW)="C5^DGRPTX"
  S DU="Y:YES;N:NO;"
@@ -126,6 +126,4 @@
  S DFN=DA D EN^DGMTCOR K DGMTCOR
  S X=DE(5),DIC=DIE
- S DFN=DA D EN^DGRP7CC
- S X=DE(5),DIC=DIE
  ;
  S X=DE(5),DIC=DIE
@@ -139,6 +137,4 @@
  S X=DG(DQ),DIC=DIE
  S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGRP7CC
  S X=DG(DQ),DIC=DIE
  X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4)
@@ -175,19 +171,5 @@
  S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET
 C7S S X="" G:DG(DQ)=X C7F1 K DB
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DG(DQ),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+ D ^DGRPTX1
 C7F1 N X,X1,X2 S DIXR=230 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X
  D
@@ -212,7 +194,7 @@
  G RE
 C9 G C9S:$D(DE(9))[0 K DB
- D ^DGRPTX1
+ D ^DGRPTX2
 C9S S X="" G:DG(DQ)=X C9F1 K DB
- D ^DGRPTX2
+ D ^DGRPTX3
 C9F1 N X,X1,X2 S DIXR=232 D C9X1(U) K X2 M X2=X D C9X1("O") K X1 M X1=X
  D
@@ -233,29 +215,3 @@
 X10 S:X="" Y="@1112"
  Q
-11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113
- S DE(DW)="C11^DGRPTX",DE(DW,"INDEX")=1
- G RE
-C11 G C11S:$D(DE(11))[0 K DB
- D ^DGRPTX3
-C11S S X="" G:DG(DQ)=X C11F1 K DB
- D ^DGRPTX4
-C11F1 N X,X1,X2 S DIXR=233 D C11X1(U) K X2 M X2=X D C11X1("O") K X1 M X1=X
- D
- . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- K X M X=X2 D
- . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- G C11F2
-C11X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3))
- S X=$G(X(1))
- Q
-C11F2 Q
-X11 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X
- I $D(X),X'?.ANP K X
- Q
- ;
-12 S DQ=13 ;@1112
-13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X13 S EASZIPLK=1
- Q
-14 D:$D(DG)>9 F^DIE17 G ^DGRPTX5
+11 D:$D(DG)>9 F^DIE17 G ^DGRPTX4
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX1.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX1.m	(revision 623)
@@ -1,16 +1,16 @@
-DGRPTX1 ; ;12/13/08
- S X=DE(9),DIC=DIE
- X "S DGXRF=.112 D ^DGDDC Q"
- S X=DE(9),DIC=DIE
+DGRPTX1 ; ;04/21/06
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
- S X=DE(9),DIC=DIE
+ S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
- S X=DE(9),DIC=DIE
+ S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DE(9),DIC=DIE
+ S X=DG(DQ),DIC=DIE
  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DE(9),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA)
- S X=DE(9),DIC=DIE
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(9),DIIX=2_U_DIFLD D AUDIT^DIET
+ I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX10.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX10.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX10.m	(revision 623)
@@ -1,10 +1,216 @@
-DGRPTX10 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".132;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+DGRPTX10 ; ;04/21/06
+ D DE G BEGIN
+DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
+ I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(5)=% S %=$P(%Z,U,4) S:%]"" DE(7)=% S %=$P(%Z,U,5) S:%]"" DE(9)=% S %=$P(%Z,U,6) S:%]"" DE(10)=% S %=$P(%Z,U,7) S:%]"" DE(11)=% S %=$P(%Z,U,9) S:%]"" DE(13)=%
+ I  S %=$P(%Z,U,10) S:%]"" DE(3)=% S %=$P(%Z,U,11) S:%]"" DE(14)=%
+ I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,7) S:%]"" DE(12)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX10",DQ=1
+1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".21;2",DV="FX",DU="",DLB="K-RELATIONSHIP TO PATIENT",DIFLD=.212
+ S DE(DW)="C1^DGRPTX10",DE(DW,"INDEX")=1
+ G RE
+C1 G C1S:$D(DE(1))[0 K DB
+ S X=DE(1),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X1 K:$L(X)>30!($L(X)<1) X I $D(X) S DFN=DA D K1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A
+3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".21;10",DV="RSX",DU="",DLB="K-ADDRESS SAME AS PATIENT'S?",DIFLD=.2125
+ S DE(DW)="C3^DGRPTX10",DE(DW,"INDEX")=1
+ S DU="Y:YES;N:NO;"
+ S Y="NO"
+ G Y
+C3 G C3S:$D(DE(3))[0 K DB
+C3S S X="" G:DG(DQ)=X C3F1 K DB
+C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X3 I $D(X),X="Y" S DFN=DA D K1^DGLOCK2
+ Q
+ ;
+4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X4 I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011
+ Q
+5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".21;3",DV="FX",DU="",DLB="K-STREET ADDRESS [LINE 1]",DIFLD=.213
+ S DE(DW)="C5^DGRPTX10",DE(DW,"INDEX")=1
+ G RE
+C5 G C5S:$D(DE(5))[0 K DB
+ S X=DE(5),DIC=DIE
+ X "S DGXRF=.213 D ^DGDDC Q"
+ S X=DE(5),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C5S S X="" G:DG(DQ)=X C5F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X5 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X6 S:X="" Y=.216
+ Q
+7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".21;4",DV="FX",DU="",DLB="K-STREET ADDRESS [LINE 2]",DIFLD=.214
+ S DE(DW)="C7^DGRPTX10",DE(DW,"INDEX")=1
+ G RE
+C7 G C7S:$D(DE(7))[0 K DB
+ S X=DE(7),DIC=DIE
+ X "S DGXRF=.214 D ^DGDDC Q"
+ S X=DE(7),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C7S S X="" G:DG(DQ)=X C7F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X7 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X8 S:X="" Y=.216
+ Q
+9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".21;5",DV="FX",DU="",DLB="K-STREET ADDRESS [LINE 3]",DIFLD=.215
+ S DE(DW)="C9^DGRPTX10",DE(DW,"INDEX")=1
+ G RE
+C9 G C9S:$D(DE(9))[0 K DB
+C9S S X="" G:DG(DQ)=X C9F1 K DB
+C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X9 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".21;6",DV="FX",DU="",DLB="K-CITY",DIFLD=.216
+ S DE(DW)="C10^DGRPTX10",DE(DW,"INDEX")=1
+ G RE
+C10 G C10S:$D(DE(10))[0 K DB
+ S X=DE(10),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C10S S X="" G:DG(DQ)=X C10F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C10F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X10 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".21;7",DV="P5'X",DU="",DLB="K-STATE",DIFLD=.217
+ S DE(DW)="C11^DGRPTX10",DE(DW,"INDEX")=1
+ S DU="DIC(5,"
+ G RE
+C11 G C11S:$D(DE(11))[0 K DB
+ S X=DE(11),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C11S S X="" G:DG(DQ)=X C11F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+C11F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X11 I $D(X) S DFN=DA D K1^DGLOCK2
+ Q
+ ;
+12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".22;7",DV="FOX",DU="",DLB="K-ZIP+4",DIFLD=.2207
+ S DQ(12,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
+ S DE(DW)="C12^DGRPTX10",DE(DW,"INDEX")=1
+ G RE
+C12 G C12S:$D(DE(12))[0 K DB
+ S X=DE(12),DIC=DIE
+ D KILL^DGREGDD1(DA,.218,.21,8,$E(X,1,5))
+C12S S X="" G:DG(DQ)=X C12F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D SET^DGREGDD1(DA,.218,.21,8,$E(X,1,5))
+C12F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X12 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D K1^DGLOCK2 I $D(X) K:$L(X)>15!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".21;9",DV="FXa",DU="",DLB="K-PHONE NUMBER",DIFLD=.219
+ S DE(DW)="C13^DGRPTX10"
+ G RE
+C13 G C13S:$D(DE(13))[0 K DB
+ D ^DGRPTX11
+C13S S X="" G:DG(DQ)=X C13F1 K DB
+ D ^DGRPTX12
+C13F1 Q
+X13 K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D K1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".21;11",DV="F",DU="",DLB="K-WORK PHONE NUMBER",DIFLD=.21011
+ G RE
+X14 K:$L(X)>20!($L(X)<4) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+15 S DQ=16 ;@30
+16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X16 I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),U,1)="":1,1:0) S Y=.331
+ Q
+17 D:$D(DG)>9 F^DIE17 G ^DGRPTX13
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX11.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX11.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX11.m	(revision 623)
@@ -1,5 +1,6 @@
-DGRPTX11 ; ;12/13/08
- S X=DE(8),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(8),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+DGRPTX11 ; ;04/21/06
+ S X=DE(13),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
+ S X=DE(13),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(13),DIIX=2_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX12.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX12.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX12.m	(revision 623)
@@ -1,5 +1,6 @@
-DGRPTX12 ; ;12/13/08
+DGRPTX12 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
  S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(13))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX13.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX13.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX13.m	(revision 623)
@@ -1,8 +1,209 @@
-DGRPTX13 ; ;12/13/08
+DGRPTX13 ; ;04/21/06
+ D DE G BEGIN
+DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
+ I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,1) S:%]"" DE(16)=%
+ I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,1) S:%]"" DE(6)=% S %=$P(%Z,U,2) S:%]"" DE(8)=% S %=$P(%Z,U,3) S:%]"" DE(9)=% S %=$P(%Z,U,4) S:%]"" DE(11)=% S %=$P(%Z,U,5) S:%]"" DE(13)=% S %=$P(%Z,U,6) S:%]"" DE(14)=% S %=$P(%Z,U,7) S:%]"" DE(15)=%
+ I  S %=$P(%Z,U,10) S:%]"" DE(1)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX13",DQ=1
+1 S DW=".33;10",DV="RSX",DU="",DLB="E-EMER. CONTACT SAME AS NOK?",DIFLD=.3305
+ S DE(DW)="C1^DGRPTX13",DE(DW,"INDEX")=1
+ S DU="Y:YES;N:NO;"
+ S Y="NO"
+ G Y
+C1 G C1S:$D(DE(1))[0 K DB
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X1 I $D(X),X="Y" D K1^DGLOCK2
+ Q
+ ;
+2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X2 I X'="Y" S Y=.331
+ Q
+3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X3 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X'="" ^(.33)=$P(X_"^^^^^^^^^^^",U,1,9)_U_$P(^(.33),U,10)_U_$P(X,U,11)
+ Q
+4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X4 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7)
+ Q
+5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X5 S Y=.33011
+ Q
+6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".33;1",DV="F",DU="",DLB="E-NAME",DIFLD=.331
+ S DE(DW)="C6^DGRPTX13",DE(DW,"INDEX")=1
+ G RE
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
+ X "S DGXRF=.331 D ^DGDDC Q"
+C6S S X="" G:DG(DQ)=X C6F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+C6F1 N X,X1,X2 S DIXR=595 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
+ I $G(X(1))]"" D
+ . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1 D DELCOMP^XLFNAME2(2,.DA,.331,1.07) Q
+ K X M X=X2 I $G(X(1))]"" D
+ . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1,DG20NAME=X D NARY^XLFNAME7(.DG20NAME),UPDCOMP^XLFNAME2(2,.DA,.331,.DG20NAME,1.07,+$P($G(^DPT(DA,"NAME")),U,7),"CL35") K DG20NAME Q
+ G C6F2
+C6X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.331,DION),$P($G(^DPT(DA,.33)),U,1))
+ S X=$G(X(1))
+ Q
+C6F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X6 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NAME)=$$FORMAT^XLFNAME7(.DG20NAME,3,35) K:'$L(X) X,DG20NAME
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X7 S:X="" Y="@40"
+ Q
+8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".33;2",DV="FX",DU="",DLB="E-RELATIONSHIP TO PATIENT",DIFLD=.332
+ S DE(DW)="C8^DGRPTX13",DE(DW,"INDEX")=1
+ G RE
+C8 G C8S:$D(DE(8))[0 K DB
+C8S S X="" G:DG(DQ)=X C8F1 K DB
+C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X8 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D E1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".33;3",DV="FX",DU="",DLB="E-STREET ADDRESS [LINE 1]",DIFLD=.333
+ S DE(DW)="C9^DGRPTX13",DE(DW,"INDEX")=1
+ G RE
+C9 G C9S:$D(DE(9))[0 K DB
  S X=DE(9),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAFCDD01(DA)
- S X=DE(9),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(9),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(9),DIIX=2_U_DIFLD D AUDIT^DIET
+ X "S DGXRF=.333 D ^DGDDC Q"
+C9S S X="" G:DG(DQ)=X C9F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X9 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X10 S:X="" Y=.336
+ Q
+11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".33;4",DV="FX",DU="",DLB="E-STREET ADDRESS [LINE 2]",DIFLD=.334
+ S DE(DW)="C11^DGRPTX13",DE(DW,"INDEX")=1
+ G RE
+C11 G C11S:$D(DE(11))[0 K DB
+ S X=DE(11),DIC=DIE
+ X "S DGXRF=.334 D ^DGDDC Q"
+C11S S X="" G:DG(DQ)=X C11F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+C11F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X11 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X12 S:X="" Y=.336
+ Q
+13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".33;5",DV="FX",DU="",DLB="E-STREET ADDRESS [LINE 3]",DIFLD=.335
+ S DE(DW)="C13^DGRPTX13",DE(DW,"INDEX")=1
+ G RE
+C13 G C13S:$D(DE(13))[0 K DB
+C13S S X="" G:DG(DQ)=X C13F1 K DB
+C13F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X13 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".33;6",DV="FX",DU="",DLB="E-CITY",DIFLD=.336
+ S DE(DW)="C14^DGRPTX13",DE(DW,"INDEX")=1
+ G RE
+C14 G C14S:$D(DE(14))[0 K DB
+C14S S X="" G:DG(DQ)=X C14F1 K DB
+C14F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X14 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".33;7",DV="P5'X",DU="",DLB="E-STATE",DIFLD=.337
+ S DE(DW)="C15^DGRPTX13",DE(DW,"INDEX")=1
+ S DU="DIC(5,"
+ G RE
+C15 G C15S:$D(DE(15))[0 K DB
+C15S S X="" G:DG(DQ)=X C15F1 K DB
+C15F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X15 I $D(X) S DFN=DA D E1^DGLOCK2
+ Q
+ ;
+16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".22;1",DV="FOX",DU="",DLB="E-ZIP+4",DIFLD=.2201
+ S DQ(16,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
+ S DE(DW)="C16^DGRPTX13",DE(DW,"INDEX")=1
+ G RE
+C16 G C16S:$D(DE(16))[0 K DB
+ D ^DGRPTX14
+C16S S X="" G:DG(DQ)=X C16F1 K DB
+ D ^DGRPTX15
+C16F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
+ Q
+X16 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D E1^DGLOCK2 I $D(X) K:$L(X)>15!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+17 D:$D(DG)>9 F^DIE17 G ^DGRPTX16
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX14.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX14.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX14.m	(revision 623)
@@ -1,8 +1,3 @@
-DGRPTX14 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- I $D(DE(9))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+DGRPTX14 ; ;04/21/06
+ S X=DE(16),DIC=DIE
+ D KILL^DGREGDD1(DA,.338,.33,8,$E(X,1,5))
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX15.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX15.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX15.m	(revision 623)
@@ -1,8 +1,3 @@
-DGRPTX15 ; ;12/13/08
- S X=DE(10),DIC=DIE
- X "S DGXRF=.211 D ^DGDDC Q"
- S X=DE(10),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VAFCDD01(DA)
- S X=DE(10),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET
+DGRPTX15 ; ;04/21/06
+ S X=DG(DQ),DIC=DIE
+ D SET^DGREGDD1(DA,.338,.33,8,$E(X,1,5))
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX16.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX16.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX16.m	(revision 623)
@@ -1,8 +1,223 @@
-DGRPTX16 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+DGRPTX16 ; ;04/21/06
+ D DE G BEGIN
+DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
+ I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,5) S:%]"" DE(4)=% S %=$P(%Z,U,8) S:%]"" DE(5)=%
+ I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,9) S:%]"" DE(1)=% S %=$P(%Z,U,11) S:%]"" DE(2)=%
+ I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(6)=%
+ I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,1) S:%]"" DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(13)=% S %=$P(%Z,U,3) S:%]"" DE(17)=% S %=$P(%Z,U,4) S:%]"" DE(14)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX16",DQ=1
+1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".33;9",DV="FX",DU="",DLB="E-PHONE NUMBER",DIFLD=.339
+ G RE
+X1 K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+2 S DW=".33;11",DV="F",DU="",DLB="E-WORK PHONE NUMBER",DIFLD=.33011
+ G RE
+X2 K:$L(X)>20!($L(X)<4) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+3 S DQ=4 ;@40
+4 S DW=".32;5",DV="P23'X",DU="",DLB="SERVICE BRANCH [LAST]",DIFLD=.325
+ S DE(DW)="C4^DGRPTX16",DE(DW,"INDEX")=1
+ S DU="DIC(23,"
+ G RE
+C4 G C4S:$D(DE(4))[0 K DB
+ S X=DE(4),DIC=DIE
+ S A1B2TAG="PAT" D ^A1B2XFR
+ S X=DE(4),DIC=DIE
+ I $P($G(^DPT(DA,.321)),U,14)]"" D FVP^DGRPMS
+ S X=DE(4),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C4S S X="" G:DG(DQ)=X C4F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S A1B2TAG="PAT" D ^A1B2XFR
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C4F1 N X,X1,X2 S DIXR=408 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
+ D
+ . N DIEXARR M DIEXARR=X S DIEZCOND=1
+ . S X=X2(1)=""
+ . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
+ . D DELMSE^DGRPMS(DFN,1)
+ G C4F2
+C4X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.325,DION),$P($G(^DPT(DA,.32)),U,5))
+ S X=$G(X(1))
+ Q
+C4F2 Q
+X4 S DFN=DA K:X=$O(^DIC(23,"B","B.E.C.","")) X I $D(X) D SV^DGLOCK S DGCOMBR=$G(Y) Q
+ Q
+ ;
+5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".32;8",DV="FX",DU="",DLB="SERVICE NUMBER [LAST]",DIFLD=.328
+ S DE(DW)="C5^DGRPTX16"
+ G RE
+C5 G C5S:$D(DE(5))[0 K DB
+ S X=DE(5),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C5S S X="" G:DG(DQ)=X C5F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C5F1 Q
+X5 S DFN=DA D SV^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E "  ",L S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED?",DIFLD=.525
+ S DE(DW)="C6^DGRPTX16",DE(DW,"INDEX")=1
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
+ ;
+ S X=DE(6),DIC=DIE
+ ;
+ S X=DE(6),DIC=DIE
+ ;
+ S X=DE(6),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DE(6),DIC=DIE
+ X "S DFN=DA D EN^DGMTR K DGREQF"
+ S X=DE(6),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C6S S X="" G:DG(DQ)=X C6F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$S('$D(^DIC(22,+$P(Y(1),U,6),0)):"",1:$P(^(0),U,1)) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,7) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,2,1.4)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,8) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,3,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DG(DQ),DIC=DIE
+ X "S DFN=DA D EN^DGMTR K DGREQF"
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C6F1 N X,X1,X2 S DIXR=646 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
+ D
+ . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ K X M X=X2 D
+ . D FC^DGFCPROT(.DA,2,.525,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ G C6F2
+C6X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.525,DION),$P($G(^DPT(DA,.52)),U,5))
+ S X=$G(X(1))
+ Q
+C6F2 Q
+X6 S DFN=DA D SV^DGLOCK
+ Q
+ ;
+7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X7 I $P($G(^DPT(DFN,.53)),U)]"" S Y="@53"
+ Q
+8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".53;1",DV="SX",DU="",DLB="CURRENT PH INDICATOR",DIFLD=.531
+ S DE(DW)="C8^DGRPTX16"
+ S DU="Y:YES;N:NO;"
+ G RE
+C8 G C8S:$D(DE(8))[0 K DB
+ S X=DE(8),DIC=DIE
+ K ^DPT("D",$E(X,1,30),DA)
+ S X=DE(8),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C8S S X="" G:DG(DQ)=X C8F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^DPT("D",$E(X,1,30),DA)=""
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C8F1 Q
+X8 S DFN=DA D VET^DGLOCK
+ Q
+ ;
+9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X9 I X="Y" S Y="@532",DGPHMULT=1
+ Q
+10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X10 I X="N" S Y="@533",DGPHMULT=1
+ Q
+11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X11 S:X="" Y="@53"
+ Q
+12 S DQ=13 ;@532
+13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".53;2",DV="S",DU="",DLB="CURRENT PURPLE HEART STATUS",DIFLD=.532
+ S DE(DW)="C13^DGRPTX16"
+ S DU="1:PENDING;2:IN PROCESS;3:CONFIRMED;"
+ S X="PENDING"
+ S Y=X
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+C13 G C13S:$D(DE(13))[0 K DB
+ S X=DE(13),DIC=DIE
+ K ^DPT("C",$E(X,1,30),DA)
+C13S S X="" G:DG(DQ)=X C13F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^DPT("C",$E(X,1,30),DA)=""
+C13F1 Q
+X13 Q
+14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".53;4",DV="P4'",DU="",DLB="PH DIVISION",DIFLD=.535
+ S DU="DIC(4,"
+ S X=$$DIV^DGRPLE()
+ S Y=X
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+X14 Q
+15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X15 S Y="@53"
+ Q
+16 S DQ=17 ;@533
+17 S DW=".53;3",DV="S",DU="",DLB="CURRENT PURPLE HEART REMARKS",DIFLD=.533
+ S DU="1:UNACCEPTABLE DOCUMENTATION;2:NO DOCUMENTATION REC'D;3:ENTERED IN ERROR;4:UNSUPPORTED PURPLE HEART;5:VAMC;6:UNDELIVERABLE MAIL;"
+ S X="VAMC"
+ S Y=X
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+X17 Q
+18 D:$D(DG)>9 F^DIE17 G ^DGRPTX17
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX17.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX17.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX17.m	(revision 623)
@@ -1,9 +1,11 @@
-DGRPTX17 ; ;12/13/08
+DGRPTX17 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(5)=% S %=$P(%Z,U,4) S:%]"" DE(7)=% S %=$P(%Z,U,5) S:%]"" DE(9)=% S %=$P(%Z,U,6) S:%]"" DE(10)=% S %=$P(%Z,U,7) S:%]"" DE(11)=% S %=$P(%Z,U,9) S:%]"" DE(13)=%
- I  S %=$P(%Z,U,10) S:%]"" DE(3)=% S %=$P(%Z,U,11) S:%]"" DE(14)=%
- I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,7) S:%]"" DE(12)=%
- I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,1) S:%]"" DE(22)=% S %=$P(%Z,U,10) S:%]"" DE(17)=%
+ I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(7)=% S %=$P(%Z,U,2) S:%]"" DE(9)=%
+ I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,2) S:%]"" DE(3)=% S %=$P(%Z,U,3) S:%]"" DE(4)=%
+ I $D(^(.322)) S %Z=^(.322) S %=$P(%Z,U,13) S:%]"" DE(5)=%
+ I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,2) S:%]"" DE(6)=%
+ I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(11)=% S %=$P(%Z,U,13) S:%]"" DE(12)=%
+ I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,4) S:%]"" DE(1)=%
  K %Z Q
  ;
@@ -53,225 +55,174 @@
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="DGRPTX17",DQ=1
-1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".21;2",DV="FX",DU="",DLB="K-RELATIONSHIP TO PATIENT",DIFLD=.212
- S DE(DW)="C1^DGRPTX17",DE(DW,"INDEX")=1
- G RE
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X1 K:$L(X)>30!($L(X)<1) X I $D(X) S DFN=DA D K1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A
-3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".21;10",DV="RSX",DU="",DLB="K-ADDRESS SAME AS PATIENT'S?",DIFLD=.2125
- S DE(DW)="C3^DGRPTX17",DE(DW,"INDEX")=1
- S DU="Y:YES;N:NO;"
- S Y="NO"
- G Y
+1 S DW=".53;4",DV="P4'",DU="",DLB="PH DIVISION",DIFLD=.535
+ S DU="DIC(4,"
+ S X=$$DIV^DGRPLE()
+ S Y=X
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+X1 Q
+2 S DQ=3 ;@53
+3 S DW=".321;2",DV="RSX",DU="",DLB="AGENT ORANGE EXPOS. INDICATED?",DIFLD=.32102
+ S DE(DW)="C3^DGRPTX17"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
 C3 G C3S:$D(DE(3))[0 K DB
+ S X=DE(3),DIC=DIE
+ ;
+ S X=DE(3),DIC=DIE
+ ;
+ S X=DE(3),DIC=DIE
+ ;
+ S X=DE(3),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DE(3),DIC=DIE
+ ;
 C3S S X="" G:DG(DQ)=X C3F1 K DB
-C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X3 I $D(X),X="Y" S DFN=DA D K1^DGLOCK2
- Q
- ;
-4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X4 I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011
- Q
-5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".21;3",DV="FX",DU="",DLB="K-STREET ADDRESS [LINE 1]",DIFLD=.213
- S DE(DW)="C5^DGRPTX17",DE(DW,"INDEX")=1
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.32102,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,7) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32102,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.32102,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,9) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32102,1,2,1.4)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.32102,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,10) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32102,1,3,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.32102,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.321)),DIV=X S $P(^(.321),U,13)=DIV,DIH=2,DIG=.3213 D ^DICR
+C3F1 Q
+X3 S DFN=DA D SV^DGLOCK
+ Q
+ ;
+4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".321;3",DV="RSX",DU="",DLB="RADIATION EXPOSURE INDICATED?",DIFLD=.32103
+ S DE(DW)="C4^DGRPTX17"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
+C4 G C4S:$D(DE(4))[0 K DB
+ S X=DE(4),DIC=DIE
+ ;
+ S X=DE(4),DIC=DIE
+ ;
+ S X=DE(4),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C4S S X="" G:DG(DQ)=X C4F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.32103,1,1,1.3) I X S X=DIV S Y(2)=";"_$S($D(^DD(2,.3212,0)):$P(^(0),U,3),1:""),Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P($P(Y(2),";"_$P(Y(1),U,12)_":",2),";",1) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32103,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.32103,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,11) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32103,1,2,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C4F1 Q
+X4 S DFN=DA D SV^DGLOCK
+ Q
+ ;
+5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".322;13",DV="RSX",DU="",DLB="ENVIRONMENTAL CONTAMINANTS?",DIFLD=.322013
+ S DE(DW)="C5^DGRPTX17"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
  G RE
 C5 G C5S:$D(DE(5))[0 K DB
  S X=DE(5),DIC=DIE
- X "S DGXRF=.213 D ^DGDDC Q"
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,1,2.4)
  S X=DE(5),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,2,2.4)
+ S X=DE(5),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C5S S X="" G:DG(DQ)=X C5F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.322013,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.322013,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,2,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C5F1 Q
+X5 S DFN=DA D SV^DGLOCK
+ Q
+ ;
+6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".36;2",DV="RSX",DU="",DLB="DISABILITY RET. FROM MILITARY?",DIFLD=.362
+ S DE(DW)="C6^DGRPTX17"
+ S DU="0:NO;1:YES, RECEIVING MILITARY RETIREMENT;2:YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA COMPENSATION;3:UNKNOWN;"
+ G RE
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
+ ;
+ S X=DE(6),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C6S S X="" G:DG(DQ)=X C6F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X "S DFN=DA D EN^DGMTR K DGREQF"
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C6F1 Q
+X6 S DFN=DA D SV^DGLOCK
+ Q
+ ;
+7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301
+ S DE(DW)="C7^DGRPTX17"
+ S DU="Y:YES;N:NO;"
+ G RE
+C7 G C7S:$D(DE(7))[0 K DB
+ S X=DE(7),DIC=DIE
+ ;
+ S X=DE(7),DIC=DIE
+ ;
+ S X=DE(7),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DE(7),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA)
+ S X=DE(7),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C5S S X="" G:DG(DQ)=X C5F1 K DB
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
+ S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET
+C7S S X="" G:DG(DQ)=X C7F1 K DB
+ D ^DGRPTX18
+C7F1 Q
+X7 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK
+ Q
+ ;
+8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X8 S:X'="Y" Y="@50"
+ Q
+9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".3;2",DV="NJ3,0Xa",DU="",DLB="SERVICE CONNECTED PERCENTAGE",DIFLD=.302
+ S DE(DW)="C9^DGRPTX17"
+ G RE
+C9 G C9S:$D(DE(9))[0 K DB
+ S X=DE(9),DIC=DIE
+ ;
+ S X=DE(9),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DE(9),DIC=DIE
+ ;
+ S X=DE(9),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA)
+ S X=DE(9),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X5 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X6 S:X="" Y=.216
- Q
-7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".21;4",DV="FX",DU="",DLB="K-STREET ADDRESS [LINE 2]",DIFLD=.214
- S DE(DW)="C7^DGRPTX17",DE(DW,"INDEX")=1
- G RE
-C7 G C7S:$D(DE(7))[0 K DB
- S X=DE(7),DIC=DIE
- X "S DGXRF=.214 D ^DGDDC Q"
- S X=DE(7),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C7S S X="" G:DG(DQ)=X C7F1 K DB
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X7 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X8 S:X="" Y=.216
- Q
-9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".21;5",DV="FX",DU="",DLB="K-STREET ADDRESS [LINE 3]",DIFLD=.215
- S DE(DW)="C9^DGRPTX17",DE(DW,"INDEX")=1
- G RE
-C9 G C9S:$D(DE(9))[0 K DB
+ S X=DE(9),DIIX=2_U_DIFLD D AUDIT^DIET
 C9S S X="" G:DG(DQ)=X C9F1 K DB
-C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X9 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".21;6",DV="FX",DU="",DLB="K-CITY",DIFLD=.216
- S DE(DW)="C10^DGRPTX17",DE(DW,"INDEX")=1
- G RE
-C10 G C10S:$D(DE(10))[0 K DB
- S X=DE(10),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C10S S X="" G:DG(DQ)=X C10F1 K DB
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C10F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X10 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".21;7",DV="P5'X",DU="",DLB="K-STATE",DIFLD=.217
- S DE(DW)="C11^DGRPTX17",DE(DW,"INDEX")=1
- S DU="DIC(5,"
+ D ^DGRPTX19
+C9F1 Q
+X9 S DFN=DA D EV^DGLOCK Q:'$D(X)  K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X),$D(^DPT(DA,.3)),$P(^(.3),U,1)'="Y" W !?4,*7,"Only applies to service-connected applicants." K X
+ Q
+ ;
+10 S DQ=11 ;@50
+11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205
+ S DE(DW)="C11^DGRPTX17"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
  G RE
 C11 G C11S:$D(DE(11))[0 K DB
- S X=DE(11),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ D ^DGRPTX20
 C11S S X="" G:DG(DQ)=X C11F1 K DB
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
-C11F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X11 I $D(X) S DFN=DA D K1^DGLOCK2
- Q
- ;
-12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".22;7",DV="FOX",DU="",DLB="K-ZIP+4",DIFLD=.2207
- S DQ(12,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
- S DE(DW)="C12^DGRPTX17",DE(DW,"INDEX")=1
+ D ^DGRPTX21
+C11F1 Q
+X11 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
+ Q
+ ;
+12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215
+ S DE(DW)="C12^DGRPTX17"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
  G RE
 C12 G C12S:$D(DE(12))[0 K DB
- S X=DE(12),DIC=DIE
- D KILL^DGREGDD1(DA,.218,.21,8,$E(X,1,5))
+ D ^DGRPTX22
 C12S S X="" G:DG(DQ)=X C12F1 K DB
- S X=DG(DQ),DIC=DIE
- D SET^DGREGDD1(DA,.218,.21,8,$E(X,1,5))
-C12F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X12 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D K1^DGLOCK2 I $D(X) K:$L(X)>15!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
- I $D(X),X'?.ANP K X
- Q
- ;
-13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".21;9",DV="FXa",DU="",DLB="K-PHONE NUMBER",DIFLD=.219
- S DE(DW)="C13^DGRPTX17"
- G RE
-C13 G C13S:$D(DE(13))[0 K DB
- S X=DE(13),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
- S X=DE(13),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(13),DIIX=2_U_DIFLD D AUDIT^DIET
-C13S S X="" G:DG(DQ)=X C13F1 K DB
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(13))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C13F1 Q
-X13 K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D K1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".21;11",DV="F",DU="",DLB="K-WORK PHONE NUMBER",DIFLD=.21011
- G RE
-X14 K:$L(X)>20!($L(X)<4) X
- I $D(X),X'?.ANP K X
- Q
- ;
-15 S DQ=16 ;@30
-16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X16 I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),U,1)="":1,1:0) S Y=.331
- Q
-17 S DW=".33;10",DV="RSX",DU="",DLB="E-EMER. CONTACT SAME AS NOK?",DIFLD=.3305
- S DE(DW)="C17^DGRPTX17",DE(DW,"INDEX")=1
- S DU="Y:YES;N:NO;"
- S Y="NO"
- G Y
-C17 G C17S:$D(DE(17))[0 K DB
-C17S S X="" G:DG(DQ)=X C17F1 K DB
-C17F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X17 I $D(X),X="Y" D K1^DGLOCK2
- Q
- ;
-18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X18 I X'="Y" S Y=.331
- Q
-19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X19 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X'="" ^(.33)=$P(X_"^^^^^^^^^^^",U,1,9)_U_$P(^(.33),U,10)_U_$P(X,U,11)
- Q
-20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X20 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7)
- Q
-21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X21 S Y=.33011
- Q
-22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW=".33;1",DV="F",DU="",DLB="E-NAME",DIFLD=.331
- S DE(DW)="C22^DGRPTX17",DE(DW,"INDEX")=1
- G RE
-C22 G C22S:$D(DE(22))[0 K DB
- D ^DGRPTX18
-C22S S X="" G:DG(DQ)=X C22F1 K DB
- D ^DGRPTX19
-C22F1 N X,X1,X2 S DIXR=595 D C22X1(U) K X2 M X2=X D C22X1("O") K X1 M X1=X
- I $G(X(1))]"" D
- . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1 D DELCOMP^XLFNAME2(2,.DA,.331,1.07) Q
- K X M X=X2 I $G(X(1))]"" D
- . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1,DG20NAME=X D NARY^XLFNAME7(.DG20NAME),UPDCOMP^XLFNAME2(2,.DA,.331,.DG20NAME,1.07,+$P($G(^DPT(DA,"NAME")),U,7),"CL35") K DG20NAME Q
- G C22F2
-C22X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.331,DION),$P($G(^DPT(DA,.33)),U,1))
- S X=$G(X(1))
- Q
-C22F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X22 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NAME)=$$FORMAT^XLFNAME7(.DG20NAME,3,35) K:'$L(X) X,DG20NAME
- I $D(X),X'?.ANP K X
- Q
- ;
-23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X23 S:X="" Y="@40"
- Q
-24 D:$D(DG)>9 F^DIE17 G ^DGRPTX20
+ D ^DGRPTX23
+C12F1 Q
+X12 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
+ Q
+ ;
+13 D:$D(DG)>9 F^DIE17 G ^DGRPTX24
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX18.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX18.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX18.m	(revision 623)
@@ -1,3 +1,12 @@
-DGRPTX18 ; ;12/13/08
- S X=DE(22),DIC=DIE
- X "S DGXRF=.331 D ^DGDDC Q"
+DGRPTX18 ; ;04/21/06
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX19.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX19.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX19.m	(revision 623)
@@ -1,3 +1,12 @@
-DGRPTX19 ; ;12/13/08
+DGRPTX19 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  ;
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DG(DQ),DIC=DIE
+ X "S DFN=DA D EN^DGMTR K DGREQF"
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(9))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX2.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX2.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX2.m	(revision 623)
@@ -1,16 +1,16 @@
-DGRPTX2 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
+DGRPTX2 ; ;04/21/06
+ S X=DE(9),DIC=DIE
+ X "S DGXRF=.112 D ^DGDDC Q"
+ S X=DE(9),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
- S X=DG(DQ),DIC=DIE
+ S X=DE(9),DIC=DIE
  D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
+ S X=DE(9),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DG(DQ),DIC=DIE
+ S X=DE(9),DIC=DIE
  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DG(DQ),DIC=DIE
+ S X=DE(9),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
+ S X=DE(9),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(9))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+ S X=DE(9),DIIX=2_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX20.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX20.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX20.m	(revision 623)
@@ -1,288 +1,9 @@
-DGRPTX20 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,1) S:%]"" DE(9)=%
- I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,5) S:%]"" DE(13)=% S %=$P(%Z,U,8) S:%]"" DE(14)=%
- I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(6)=% S %=$P(%Z,U,6) S:%]"" DE(7)=% S %=$P(%Z,U,7) S:%]"" DE(8)=% S %=$P(%Z,U,9) S:%]"" DE(10)=%
- I  S %=$P(%Z,U,11) S:%]"" DE(11)=%
- I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(15)=%
- I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,1) S:%]"" DE(17)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPTX20",DQ=1
-1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".33;2",DV="FX",DU="",DLB="E-RELATIONSHIP TO PATIENT",DIFLD=.332
- S DE(DW)="C1^DGRPTX20",DE(DW,"INDEX")=1
- G RE
-C1 G C1S:$D(DE(1))[0 K DB
-C1S S X="" G:DG(DQ)=X C1F1 K DB
-C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X1 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D E1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".33;3",DV="FX",DU="",DLB="E-STREET ADDRESS [LINE 1]",DIFLD=.333
- S DE(DW)="C2^DGRPTX20",DE(DW,"INDEX")=1
- G RE
-C2 G C2S:$D(DE(2))[0 K DB
- S X=DE(2),DIC=DIE
- X "S DGXRF=.333 D ^DGDDC Q"
-C2S S X="" G:DG(DQ)=X C2F1 K DB
- S X=DG(DQ),DIC=DIE
- ;
-C2F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X2 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X3 S:X="" Y=.336
- Q
-4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".33;4",DV="FX",DU="",DLB="E-STREET ADDRESS [LINE 2]",DIFLD=.334
- S DE(DW)="C4^DGRPTX20",DE(DW,"INDEX")=1
- G RE
-C4 G C4S:$D(DE(4))[0 K DB
- S X=DE(4),DIC=DIE
- X "S DGXRF=.334 D ^DGDDC Q"
-C4S S X="" G:DG(DQ)=X C4F1 K DB
- S X=DG(DQ),DIC=DIE
- ;
-C4F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X5 S:X="" Y=.336
- Q
-6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".33;5",DV="FX",DU="",DLB="E-STREET ADDRESS [LINE 3]",DIFLD=.335
- S DE(DW)="C6^DGRPTX20",DE(DW,"INDEX")=1
- G RE
-C6 G C6S:$D(DE(6))[0 K DB
-C6S S X="" G:DG(DQ)=X C6F1 K DB
-C6F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X6 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".33;6",DV="FX",DU="",DLB="E-CITY",DIFLD=.336
- S DE(DW)="C7^DGRPTX20",DE(DW,"INDEX")=1
- G RE
-C7 G C7S:$D(DE(7))[0 K DB
-C7S S X="" G:DG(DQ)=X C7F1 K DB
-C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X7 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".33;7",DV="P5'X",DU="",DLB="E-STATE",DIFLD=.337
- S DE(DW)="C8^DGRPTX20",DE(DW,"INDEX")=1
- S DU="DIC(5,"
- G RE
-C8 G C8S:$D(DE(8))[0 K DB
-C8S S X="" G:DG(DQ)=X C8F1 K DB
-C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X8 I $D(X) S DFN=DA D E1^DGLOCK2
- Q
- ;
-9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".22;1",DV="FOX",DU="",DLB="E-ZIP+4",DIFLD=.2201
- S DQ(9,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
- S DE(DW)="C9^DGRPTX20",DE(DW,"INDEX")=1
- G RE
-C9 G C9S:$D(DE(9))[0 K DB
- S X=DE(9),DIC=DIE
- D KILL^DGREGDD1(DA,.338,.33,8,$E(X,1,5))
-C9S S X="" G:DG(DQ)=X C9F1 K DB
- S X=DG(DQ),DIC=DIE
- D SET^DGREGDD1(DA,.338,.33,8,$E(X,1,5))
-C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=604 S DIEZRXR(2,DIXR)=""
- Q
-X9 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D E1^DGLOCK2 I $D(X) K:$L(X)>15!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
- I $D(X),X'?.ANP K X
- Q
- ;
-10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".33;9",DV="FX",DU="",DLB="E-PHONE NUMBER",DIFLD=.339
- G RE
-X10 K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
- I $D(X),X'?.ANP K X
- Q
- ;
-11 S DW=".33;11",DV="F",DU="",DLB="E-WORK PHONE NUMBER",DIFLD=.33011
- G RE
-X11 K:$L(X)>20!($L(X)<4) X
- I $D(X),X'?.ANP K X
- Q
- ;
-12 S DQ=13 ;@40
-13 S DW=".32;5",DV="P23'X",DU="",DLB="SERVICE BRANCH [LAST]",DIFLD=.325
- S DE(DW)="C13^DGRPTX20",DE(DW,"INDEX")=1
- S DU="DIC(23,"
- G RE
-C13 G C13S:$D(DE(13))[0 K DB
- S X=DE(13),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
- S X=DE(13),DIC=DIE
- I $P($G(^DPT(DA,.321)),U,14)]"" D FVP^DGRPMS
- S X=DE(13),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(13),DIC=DIE
- X "S DGXRF=.325 D ^DGDDC Q"
-C13S S X="" G:DG(DQ)=X C13F1 K DB
- S X=DG(DQ),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
- ;
-C13F1 N X,X1,X2 S DIXR=408 D C13X1(U) K X2 M X2=X D C13X1("O") K X1 M X1=X
- D
- . N DIEXARR M DIEXARR=X S DIEZCOND=1
- . S X=X2(1)=""
- . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
- . D DELMSE^DGRPMS(DA,1)
- G C13F2
-C13X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.325,DION),$P($G(^DPT(DA,.32)),U,5))
- S X=$G(X(1))
- Q
-C13F2 Q
-X13 S DFN=DA K:X=$O(^DIC(23,"B","B.E.C.","")) X I $D(X) D SV^DGLOCK S DGCOMBR=$G(Y) Q
- Q
- ;
-14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".32;8",DV="FX",DU="",DLB="SERVICE NUMBER [LAST]",DIFLD=.328
- S DE(DW)="C14^DGRPTX20"
- G RE
-C14 G C14S:$D(DE(14))[0 K DB
- S X=DE(14),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C14S S X="" G:DG(DQ)=X C14F1 K DB
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C14F1 Q
-X14 S DFN=DA D SV^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E "  ",L S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X
- I $D(X),X'?.ANP K X
- Q
- ;
-15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED?",DIFLD=.525
- S DE(DW)="C15^DGRPTX20",DE(DW,"INDEX")=1
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C15 G C15S:$D(DE(15))[0 K DB
- S X=DE(15),DIC=DIE
- ;
- S X=DE(15),DIC=DIE
- ;
- S X=DE(15),DIC=DIE
- ;
- S X=DE(15),DIC=DIE
+DGRPTX20 ; ;04/21/06
+ S X=DE(11),DIC=DIE
+ X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4)
+ S X=DE(11),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DE(11),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4)
+ S X=DE(11),DIC=DIE
  D AUTOUPD^DGENA2(DA)
- S X=DE(15),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
- S X=DE(15),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C15S S X="" G:DG(DQ)=X C15F1 K DB
- D ^DGRPTX21
-C15F1 N X,X1,X2 S DIXR=646 D C15X1(U) K X2 M X2=X D C15X1("O") K X1 M X1=X
- D
- . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- K X M X=X2 D
- . D FC^DGFCPROT(.DA,2,.525,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- G C15F2
-C15X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.525,DION),$P($G(^DPT(DA,.52)),U,5))
- S X=$G(X(1))
- Q
-C15F2 Q
-X15 S DFN=DA D SV^DGLOCK
- Q
- ;
-16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X16 I $P($G(^DPT(DFN,.53)),U)]"" S Y="@53"
- Q
-17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW=".53;1",DV="SX",DU="",DLB="CURRENT PH INDICATOR",DIFLD=.531
- S DE(DW)="C17^DGRPTX20"
- S DU="Y:YES;N:NO;"
- G RE
-C17 G C17S:$D(DE(17))[0 K DB
- S X=DE(17),DIC=DIE
- K ^DPT("D",$E(X,1,30),DA)
- S X=DE(17),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C17S S X="" G:DG(DQ)=X C17F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^DPT("D",$E(X,1,30),DA)=""
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C17F1 Q
-X17 S DFN=DA D VET^DGLOCK
- Q
- ;
-18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X18 I X="Y" S Y="@532",DGPHMULT=1
- Q
-19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X19 I X="N" S Y="@533",DGPHMULT=1
- Q
-20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X20 S:X="" Y="@53"
- Q
-21 S DQ=22 ;@532
-22 D:$D(DG)>9 F^DIE17 G ^DGRPTX22
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX21.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX21.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX21.m	(revision 623)
@@ -1,13 +1,9 @@
-DGRPTX21 ; ;12/13/08
+DGRPTX21 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
- X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$S('$D(^DIC(22,+$P(Y(1),U,6),0)):"",1:$P(^(0),U,1)) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,1,1.4)
+ X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)
  S X=DG(DQ),DIC=DIE
- X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,7) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,2,1.4)
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
  S X=DG(DQ),DIC=DIE
- X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,8) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,3,1.4)
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4)
  S X=DG(DQ),DIC=DIE
  D AUTOUPD^DGENA2(DA)
- S X=DG(DQ),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX22.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX22.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX22.m	(revision 623)
@@ -1,273 +1,9 @@
-DGRPTX22 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(12)=% S %=$P(%Z,U,2) S:%]"" DE(14)=%
- I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,2) S:%]"" DE(8)=% S %=$P(%Z,U,3) S:%]"" DE(9)=%
- I $D(^(.322)) S %Z=^(.322) S %=$P(%Z,U,13) S:%]"" DE(10)=%
- I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,2) S:%]"" DE(11)=%
- I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(16)=% S %=$P(%Z,U,13) S:%]"" DE(17)=%
- I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(5)=% S %=$P(%Z,U,4) S:%]"" DE(2)=%,DE(6)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPTX22",DQ=1
-1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".53;2",DV="S",DU="",DLB="CURRENT PURPLE HEART STATUS",DIFLD=.532
- S DE(DW)="C1^DGRPTX22"
- S DU="1:PENDING;2:IN PROCESS;3:CONFIRMED;"
- S X="PENDING"
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- K ^DPT("C",$E(X,1,30),DA)
- S X=DE(1),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^DPT("C",$E(X,1,30),DA)=""
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C1F1 Q
-X1 Q
-2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".53;4",DV="P4'",DU="",DLB="PH DIVISION",DIFLD=.535
- S DU="DIC(4,"
- S X=$$DIV^DGRPLE()
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD
-X2 Q
-3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X3 S Y="@53"
- Q
-4 S DQ=5 ;@533
-5 S DW=".53;3",DV="S",DU="",DLB="CURRENT PURPLE HEART REMARKS",DIFLD=.533
- S DE(DW)="C5^DGRPTX22"
- S DU="1:UNACCEPTABLE DOCUMENTATION;2:NO DOCUMENTATION REC'D;3:ENTERED IN ERROR;4:UNSUPPORTED PURPLE HEART;5:VAMC;6:UNDELIVERABLE MAIL;"
- S X="VAMC"
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD
-C5 G C5S:$D(DE(5))[0 K DB
- S X=DE(5),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C5S S X="" G:DG(DQ)=X C5F1 K DB
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C5F1 Q
-X5 Q
-6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".53;4",DV="P4'",DU="",DLB="PH DIVISION",DIFLD=.535
- S DU="DIC(4,"
- S X=$$DIV^DGRPLE()
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD
-X6 Q
-7 S DQ=8 ;@53
-8 S DW=".321;2",DV="RSX",DU="",DLB="AGENT ORANGE EXPOS. INDICATED?",DIFLD=.32102
- S DE(DW)="C8^DGRPTX22"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C8 G C8S:$D(DE(8))[0 K DB
- S X=DE(8),DIC=DIE
- ;
- S X=DE(8),DIC=DIE
- ;
- S X=DE(8),DIC=DIE
- ;
- S X=DE(8),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- S X=DE(8),DIC=DIE
- ;
-C8S S X="" G:DG(DQ)=X C8F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.32102,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,7) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32102,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.32102,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,9) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32102,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.32102,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,10) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32102,1,3,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.32102,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.321)),DIV=X S $P(^(.321),U,13)=DIV,DIH=2,DIG=.3213 D ^DICR
-C8F1 Q
-X8 S DFN=DA D SV^DGLOCK
- Q
- ;
-9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".321;3",DV="RSX",DU="",DLB="RADIATION EXPOSURE INDICATED?",DIFLD=.32103
- S DE(DW)="C9^DGRPTX22"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C9 G C9S:$D(DE(9))[0 K DB
- S X=DE(9),DIC=DIE
- ;
- S X=DE(9),DIC=DIE
- ;
- S X=DE(9),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C9S S X="" G:DG(DQ)=X C9F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.32103,1,1,1.3) I X S X=DIV S Y(2)=";"_$S($D(^DD(2,.3212,0)):$P(^(0),U,3),1:""),Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P($P(Y(2),";"_$P(Y(1),U,12)_":",2),";",1) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32103,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.32103,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,11) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32103,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C9F1 Q
-X9 S DFN=DA D SV^DGLOCK
- Q
- ;
-10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".322;13",DV="RSX",DU="",DLB="ENVIRONMENTAL CONTAMINANTS?",DIFLD=.322013
- S DE(DW)="C10^DGRPTX22"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C10 G C10S:$D(DE(10))[0 K DB
- S X=DE(10),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,1,2.4)
- S X=DE(10),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,2,2.4)
- S X=DE(10),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C10S S X="" G:DG(DQ)=X C10F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.322013,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.322013,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.322)):^(.322),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" X ^DD(2,.322013,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C10F1 Q
-X10 S DFN=DA D SV^DGLOCK
- Q
- ;
-11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".36;2",DV="RSX",DU="",DLB="DISABILITY RET. FROM MILITARY?",DIFLD=.362
- S DE(DW)="C11^DGRPTX22"
- S DU="0:NO;1:YES, RECEIVING MILITARY RETIREMENT;2:YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA COMPENSATION;3:UNKNOWN;"
- G RE
-C11 G C11S:$D(DE(11))[0 K DB
- S X=DE(11),DIC=DIE
- ;
- S X=DE(11),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C11S S X="" G:DG(DQ)=X C11F1 K DB
- S X=DG(DQ),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C11F1 Q
-X11 S DFN=DA D SV^DGLOCK
- Q
- ;
-12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".3;1",DV="SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301
- S DE(DW)="C12^DGRPTX22"
- S DU="Y:YES;N:NO;"
- G RE
-C12 G C12S:$D(DE(12))[0 K DB
+DGRPTX22 ; ;04/21/06
  S X=DE(12),DIC=DIE
- ;
+ X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4)
  S X=DE(12),DIC=DIE
- ;
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DE(12),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4)
  S X=DE(12),DIC=DIE
  D AUTOUPD^DGENA2(DA)
- S X=DE(12),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA)
- S X=DE(12),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET
-C12S S X="" G:DG(DQ)=X C12F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C12F1 Q
-X12 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK
- Q
- ;
-13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X13 S:X'="Y" Y="@50"
- Q
-14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".3;2",DV="NJ3,0Xa",DU="",DLB="SERVICE CONNECTED PERCENTAGE",DIFLD=.302
- S DE(DW)="C14^DGRPTX22"
- G RE
-C14 G C14S:$D(DE(14))[0 K DB
- D ^DGRPTX23
-C14S S X="" G:DG(DQ)=X C14F1 K DB
- D ^DGRPTX24
-C14F1 Q
-X14 S DFN=DA D EV^DGLOCK Q:'$D(X)  K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X),$D(^DPT(DA,.3)),$P(^(.3),U,1)'="Y" W !?4,*7,"Only applies to service-connected applicants." K X
- Q
- ;
-15 S DQ=16 ;@50
-16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205
- S DE(DW)="C16^DGRPTX22"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C16 G C16S:$D(DE(16))[0 K DB
- D ^DGRPTX25
-C16S S X="" G:DG(DQ)=X C16F1 K DB
- D ^DGRPTX26
-C16F1 Q
-X16 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
- Q
- ;
-17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215
- S DE(DW)="C17^DGRPTX22"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C17 G C17S:$D(DE(17))[0 K DB
- D ^DGRPTX27
-C17S S X="" G:DG(DQ)=X C17F1 K DB
- D ^DGRPTX28
-C17F1 Q
-X17 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
- Q
- ;
-18 D:$D(DG)>9 F^DIE17 G ^DGRPTX29
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX23.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX23.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX23.m	(revision 623)
@@ -1,12 +1,9 @@
-DGRPTX23 ; ;12/13/08
- S X=DE(14),DIC=DIE
- ;
- S X=DE(14),DIC=DIE
+DGRPTX23 ; ;04/21/06
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4)
+ S X=DG(DQ),DIC=DIE
  D AUTOUPD^DGENA2(DA)
- S X=DE(14),DIC=DIE
- ;
- S X=DE(14),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA)
- S X=DE(14),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(14),DIIX=2_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX24.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX24.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX24.m	(revision 623)
@@ -1,12 +1,150 @@
-DGRPTX24 ; ;12/13/08
+DGRPTX24 ; ;04/21/06
+ D DE G BEGIN
+DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
+ I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,3) S:%]"" DE(4)=%
+ I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(2)=%
+ I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,14) S:%]"" DE(1)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX24",DQ=1
+1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235
+ S DE(DW)="C1^DGRPTX24"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
+C1 G C1S:$D(DE(1))[0 K DB
+ S X=DE(1),DIC=DIE
+ X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4)
+ S X=DE(1),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DE(1),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4)
+ S X=DE(1),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C1F1 Q
+X1 S DFN=DA D MV^DGLOCK
+ Q
+ ;
+2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361
+ S DE(DW)="C2^DGRPTX24"
+ S DU="DIC(8,"
+ G RE
+C2 G C2S:$D(DE(2))[0 K DB
+ S X=DE(2),DIC=DIE
+ ;
+ S X=DE(2),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK
+ S X=DE(2),DIC=DIE
+ X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q"
+ S X=DE(2),DIC=DIE
+ K ^DPT("AEL",DA,+X)
+ S X=DE(2),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET
+C2S S X="" G:DG(DQ)=X C2F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X "S DFN=DA D EN^DGMTR K DGREQF"
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4)
  S X=DG(DQ),DIC=DIE
  ;
  S X=DG(DQ),DIC=DIE
+ S ^DPT("AEL",DA,+X)=""
+ S X=DG(DQ),DIC=DIE
  D AUTOUPD^DGENA2(DA)
+ I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C2F1 Q
+X2 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1
+ Q
+ ;
+3 D:$D(DG)>9 F^DIE17,DE S DQ=3,D=0 K DE(1) ;361
+ S DIFLD=361,DGO="^DGRPTX25",DC="3^2.0361IP^E^",DV="2.0361M*P8'X",DW="0;1",DOW="ELIGIBILITY",DLB="Select "_DOW S:D DC=DC_D
+ S DU="DIC(8,"
+ G RE:D I $D(DSC(2.0361))#2,$P(DSC(2.0361),"I $D(^UTILITY(",1)="" X DSC(2.0361) S D=$O(^(0)) S:D="" D=-1 G M3
+ S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
+M3 I D>0 S DC=DC_D I $D(^DPT(DA,"E",+D,0)) S DE(3)=$P(^(0),U,1)
+ G RE
+R3 D DE
+ S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),1:1) G 3+1
+ ;
+4 S DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVICE",DIFLD=.323
+ S DE(DW)="C4^DGRPTX24"
+ S DU="DIC(21,"
+ G RE
+C4 G C4S:$D(DE(4))[0 K DB
+ S X=DE(4),DIC=DIE
+ K ^DPT("APOS",$E(X,1,30),DA)
+ S X=DE(4),DIC=DIE
+ ;
+ S X=DE(4),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
+ S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET
+C4S S X="" G:DG(DQ)=X C4F1 K DB
  S X=DG(DQ),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
+ S ^DPT("APOS",$E(X,1,30),DA)=""
  S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA)
+ X ^DD(2,.323,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,"ODS")):^("ODS"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(2,.323,1,2,1.1) X ^DD(2,.323,1,2,1.4)
  S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(14))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
+ I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C4F1 Q
+X4 S DFN=DA D POS^DGLOCK1
+ Q
+ ;
+5 S DQ=6 ;@98
+6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X6 S DGFIN=""
+ Q
+7 G 0^DIE17
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX25.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX25.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX25.m	(revision 623)
@@ -1,9 +1,82 @@
-DGRPTX25 ; ;12/13/08
- S X=DE(16),DIC=DIE
- X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4)
- S X=DE(16),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DE(16),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4)
- S X=DE(16),DIC=DIE
- D AUTOUPD^DGENA2(DA)
+DGRPTX25 ; ;04/21/06
+ D DE G BEGIN
+DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX25",DQ=1+D G B
+1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD=.01
+ S DE(DW)="C1^DGRPTX25"
+ S DU="DIC(8,"
+ G RE:'D S DQ=2 G 2
+C1 G C1S:$D(DE(1))[0 K DB
+ S X=DE(1),DIC=DIE
+ K ^DPT(DA(1),"E","B",$E(X,1,30),DA)
+ S X=DE(1),DIC=DIE
+ K ^DPT("AEL",DA(1),+X)
+ S X=DE(1),DIC=DIE
+ D E32^VADPT62
+ S X=DE(1),DIC=DIE
+ X "S DFN=DA(1) D EN^DGMTR K DGREQF"
+ S X=DE(1),DIC=DIE
+ D AUTOUPD^DGENA2(DA(1))
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^DPT(DA(1),"E","B",$E(X,1,30),DA)=""
+ S X=DG(DQ),DIC=DIE
+ S ^DPT("AEL",DA(1),+X)=""
+ S X=DG(DQ),DIC=DIE
+ D E31^VADPT62
+ S X=DG(DQ),DIC=DIE
+ X "S DFN=DA(1) D EN^DGMTR K DGREQF"
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA(1))
+C1F1 Q
+X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) S DINUM=X
+ Q
+ ;
+2 G 1^DIE17
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX26.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX26.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX26.m	(revision 623)
@@ -1,9 +1,40 @@
-DGRPTX26 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
+DGRPTX26 ; ;04/21/06
+ ;;
+1 N X,X1,X2 S DIXR=602 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+ D
+ . D PNOK^DGDDDTTM
+ K X M X=X2 D
+ . D PNOK^DGDDDTTM
+ Q
+X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.211,DION),$P($G(^DPT(DA,.21)),U,1))
+ S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.212,DION),$P($G(^DPT(DA,.21)),U,2))
+ S X(3)=$G(@DIEZTMP@("V",2,DIIENS,.213,DION),$P($G(^DPT(DA,.21)),U,3))
+ S X(4)=$G(@DIEZTMP@("V",2,DIIENS,.214,DION),$P($G(^DPT(DA,.21)),U,4))
+ S X(5)=$G(@DIEZTMP@("V",2,DIIENS,.215,DION),$P($G(^DPT(DA,.21)),U,5))
+ S X(6)=$G(@DIEZTMP@("V",2,DIIENS,.216,DION),$P($G(^DPT(DA,.21)),U,6))
+ S X(7)=$G(@DIEZTMP@("V",2,DIIENS,.217,DION),$P($G(^DPT(DA,.21)),U,7))
+ S X(8)=$G(@DIEZTMP@("V",2,DIIENS,.218,DION),$P($G(^DPT(DA,.21)),U,8))
+ S X(9)=$G(@DIEZTMP@("V",2,DIIENS,.2125,DION),$P($G(^DPT(DA,.21)),U,10))
+ S X(10)=$G(@DIEZTMP@("V",2,DIIENS,.2207,DION),$P($G(^DPT(DA,.22)),U,7))
+ S X=$G(X(1))
+ Q
+2 N X,X1,X2 S DIXR=604 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+ D
+ . D ECON^DGDDDTTM
+ K X M X=X2 D
+ . D ECON^DGDDDTTM
+ Q
+X2(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.331,DION),$P($G(^DPT(DA,.33)),U,1))
+ S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.332,DION),$P($G(^DPT(DA,.33)),U,2))
+ S X(3)=$G(@DIEZTMP@("V",2,DIIENS,.333,DION),$P($G(^DPT(DA,.33)),U,3))
+ S X(4)=$G(@DIEZTMP@("V",2,DIIENS,.334,DION),$P($G(^DPT(DA,.33)),U,4))
+ S X(5)=$G(@DIEZTMP@("V",2,DIIENS,.335,DION),$P($G(^DPT(DA,.33)),U,5))
+ S X(6)=$G(@DIEZTMP@("V",2,DIIENS,.336,DION),$P($G(^DPT(DA,.33)),U,6))
+ S X(7)=$G(@DIEZTMP@("V",2,DIIENS,.337,DION),$P($G(^DPT(DA,.33)),U,7))
+ S X(8)=$G(@DIEZTMP@("V",2,DIIENS,.338,DION),$P($G(^DPT(DA,.33)),U,8))
+ S X(9)=$G(@DIEZTMP@("V",2,DIIENS,.3305,DION),$P($G(^DPT(DA,.33)),U,10))
+ S X(10)=$G(@DIEZTMP@("V",2,DIIENS,.2201,DION),$P($G(^DPT(DA,.22)),U,1))
+ S X=$G(X(1))
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX27.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX27.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX27.m	(revision 623)
@@ -1,9 +1,82 @@
-DGRPTX27 ; ;12/13/08
- S X=DE(17),DIC=DIE
- X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4)
- S X=DE(17),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DE(17),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4)
- S X=DE(17),DIC=DIE
- D AUTOUPD^DGENA2(DA)
+DGRPTX27 ; ;12/08/05
+ D DE G BEGIN
+DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX27",DQ=1+D G B
+1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD=.01
+ S DE(DW)="C1^DGRPTX27"
+ S DU="DIC(8,"
+ G RE:'D S DQ=2 G 2
+C1 G C1S:$D(DE(1))[0 K DB
+ S X=DE(1),DIC=DIE
+ K ^DPT(DA(1),"E","B",$E(X,1,30),DA)
+ S X=DE(1),DIC=DIE
+ K ^DPT("AEL",DA(1),+X)
+ S X=DE(1),DIC=DIE
+ D E32^VADPT62
+ S X=DE(1),DIC=DIE
+ X "S DFN=DA(1) D EN^DGMTR K DGREQF"
+ S X=DE(1),DIC=DIE
+ D AUTOUPD^DGENA2(DA(1))
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^DPT(DA(1),"E","B",$E(X,1,30),DA)=""
+ S X=DG(DQ),DIC=DIE
+ S ^DPT("AEL",DA(1),+X)=""
+ S X=DG(DQ),DIC=DIE
+ D E31^VADPT62
+ S X=DG(DQ),DIC=DIE
+ X "S DFN=DA(1) D EN^DGMTR K DGREQF"
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA(1))
+C1F1 Q
+X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) S DINUM=X
+ Q
+ ;
+2 G 1^DIE17
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX28.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX28.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX28.m	(revision 623)
@@ -1,9 +1,8 @@
-DGRPTX28 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
+DGRPTX28 ; ;12/08/05
+ S X=DE(8),DIC=DIE
+ K ^DPT("APOS",$E(X,1,30),DA)
+ S X=DE(8),DIC=DIE
+ ;
+ S X=DE(8),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
+ S X=DE(8),DIIX=2_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX29.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX29.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX29.m	(revision 623)
@@ -1,138 +1,3 @@
-DGRPTX29 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,3) S:%]"" DE(4)=%
- I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(2)=%
- I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,14) S:%]"" DE(1)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPTX29",DQ=1
-1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235
- S DE(DW)="C1^DGRPTX29"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4)
- S X=DE(1),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DE(1),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4)
- S X=DE(1),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C1F1 Q
-X1 S DFN=DA D MV^DGLOCK
- Q
- ;
-2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361
- S DE(DW)="C2^DGRPTX29"
- S DU="DIC(8,"
- G RE
-C2 G C2S:$D(DE(2))[0 K DB
- S X=DE(2),DIC=DIE
- ;
- S X=DE(2),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK
- S X=DE(2),DIC=DIE
- X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q"
- S X=DE(2),DIC=DIE
- K ^DPT("AEL",DA,+X)
- S X=DE(2),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET
-C2S S X="" G:DG(DQ)=X C2F1 K DB
- S X=DG(DQ),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- S ^DPT("AEL",DA,+X)=""
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C2F1 Q
-X2 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1
- Q
- ;
-3 D:$D(DG)>9 F^DIE17,DE S DQ=3,D=0 K DE(1) ;361
- S DIFLD=361,DGO="^DGRPTX30",DC="3^2.0361IP^E^",DV="2.0361M*P8'X",DW="0;1",DOW="ELIGIBILITY",DLB="Select "_DOW S:D DC=DC_D
- S DU="DIC(8,"
- G RE:D I $D(DSC(2.0361))#2,$P(DSC(2.0361),"I $D(^UTILITY(",1)="" X DSC(2.0361) S D=$O(^(0)) S:D="" D=-1 G M3
- S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
-M3 I D>0 S DC=DC_D I $D(^DPT(DA,"E",+D,0)) S DE(3)=$P(^(0),U,1)
- G RE
-R3 D DE
- S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),1:1) G 3+1
- ;
-4 S DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVICE",DIFLD=.323
- S DE(DW)="C4^DGRPTX29"
- S DU="DIC(21,"
- G RE
-C4 G C4S:$D(DE(4))[0 K DB
- S X=DE(4),DIC=DIE
- K ^DPT("APOS",$E(X,1,30),DA)
- S X=DE(4),DIC=DIE
- ;
- S X=DE(4),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
- S X=DE(4),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET
-C4S S X="" G:DG(DQ)=X C4F1 K DB
+DGRPTX29 ; ;12/08/05
  S X=DG(DQ),DIC=DIE
  S ^DPT("APOS",$E(X,1,30),DA)=""
@@ -141,14 +6,3 @@
  S X=DG(DQ),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C4F1 Q
-X4 S DFN=DA D POS^DGLOCK1
- Q
- ;
-5 S DQ=6 ;@98
-6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X6 S DGFIN=""
- Q
-7 G 0^DIE17
+ I $D(DE(8))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX3.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX3.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX3.m	(revision 623)
@@ -1,14 +1,16 @@
-DGRPTX3 ; ;12/13/08
- S X=DE(11),DIC=DIE
+DGRPTX3 ; ;04/21/06
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
- S X=DE(11),DIC=DIE
+ S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
- S X=DE(11),DIC=DIE
+ S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DE(11),DIC=DIE
+ S X=DG(DQ),DIC=DIE
  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DE(11),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
- S X=DE(11),DIC=DIE
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(11),DIIX=2_U_DIFLD D AUDIT^DIET
+ I $D(DE(9))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX30.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX30.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX30.m	(revision 623)
@@ -1,82 +1,21 @@
-DGRPTX30 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
+DGRPTX30 ; ;12/08/05
+ ;;
+1 N X,X1,X2 S DIXR=602 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+ D
+ . D PNOK^DGDDDTTM
+ K X M X=X2 D
+ . D PNOK^DGDDDTTM
  Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.211,DION),$P($G(^DPT(DA,.21)),U,1))
+ S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.212,DION),$P($G(^DPT(DA,.21)),U,2))
+ S X(3)=$G(@DIEZTMP@("V",2,DIIENS,.213,DION),$P($G(^DPT(DA,.21)),U,3))
+ S X(4)=$G(@DIEZTMP@("V",2,DIIENS,.214,DION),$P($G(^DPT(DA,.21)),U,4))
+ S X(5)=$G(@DIEZTMP@("V",2,DIIENS,.215,DION),$P($G(^DPT(DA,.21)),U,5))
+ S X(6)=$G(@DIEZTMP@("V",2,DIIENS,.216,DION),$P($G(^DPT(DA,.21)),U,6))
+ S X(7)=$G(@DIEZTMP@("V",2,DIIENS,.217,DION),$P($G(^DPT(DA,.21)),U,7))
+ S X(8)=$G(@DIEZTMP@("V",2,DIIENS,.218,DION),$P($G(^DPT(DA,.21)),U,8))
+ S X(9)=$G(@DIEZTMP@("V",2,DIIENS,.2125,DION),$P($G(^DPT(DA,.21)),U,10))
+ S X(10)=$G(@DIEZTMP@("V",2,DIIENS,.2207,DION),$P($G(^DPT(DA,.22)),U,7))
+ S X=$G(X(1))
  Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPTX30",DQ=1+D G B
-1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD=.01
- S DE(DW)="C1^DGRPTX30"
- S DU="DIC(8,"
- G RE:'D S DQ=2 G 2
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- K ^DPT(DA(1),"E","B",$E(X,1,30),DA)
- S X=DE(1),DIC=DIE
- K ^DPT("AEL",DA(1),+X)
- S X=DE(1),DIC=DIE
- D E32^VADPT62
- S X=DE(1),DIC=DIE
- X "S DFN=DA(1) D EN^DGMTR K DGREQF"
- S X=DE(1),DIC=DIE
- D AUTOUPD^DGENA2(DA(1))
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^DPT(DA(1),"E","B",$E(X,1,30),DA)=""
- S X=DG(DQ),DIC=DIE
- S ^DPT("AEL",DA(1),+X)=""
- S X=DG(DQ),DIC=DIE
- D E31^VADPT62
- S X=DG(DQ),DIC=DIE
- X "S DFN=DA(1) D EN^DGMTR K DGREQF"
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA(1))
-C1F1 Q
-X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) S DINUM=X
- Q
- ;
-2 G 1^DIE17
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX4.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX4.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX4.m	(revision 623)
@@ -1,14 +1,207 @@
-DGRPTX4 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
+DGRPTX4 ; ;04/21/06
+ D DE G BEGIN
+DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
+ I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,3) S:%]"" DE(1)=% S %=$P(%Z,U,4) S:%]"" DE(5)=% S %=$P(%Z,U,5) S:%]"" DE(7)=% S %=$P(%Z,U,12) S:%]"" DE(4)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX4",DQ=1
+1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113
+ S DE(DW)="C1^DGRPTX4",DE(DW,"INDEX")=1
+ G RE
+C1 G C1S:$D(DE(1))[0 K DB
+ S X=DE(1),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DG(DQ),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DG(DQ),DIC=DIE
+ S X=DE(1),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DE(1),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DE(1),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DE(1),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+ S X=DE(1),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S A1B2TAG="PAT" D ^A1B2XFR
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DG(DQ),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C1F1 N X,X1,X2 S DIXR=233 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
+ D
+ . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ K X M X=X2 D
+ . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ G C1F2
+C1X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3))
+ S X=$G(X(1))
+ Q
+C1F2 Q
+X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+2 S DQ=3 ;@1112
+3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X3 S EASZIPLK=1
+ Q
+4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112
+ S DQ(4,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
+ S DE(DW)="C4^DGRPTX4",DE(DW,"INDEX")=1
+ G RE
+C4 G C4S:$D(DE(4))[0 K DB
+ S X=DE(4),DIC=DIE
+ D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
+ S X=DE(4),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DE(4),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DE(4),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DE(4),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
+ S X=DE(4),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET
+C4S S X="" G:DG(DQ)=X C4F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DG(DQ),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C4F1 N X,X1,X2 S DIXR=185 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
+ D
+ . N DIEXARR M DIEXARR=X S DIEZCOND=1
+ . I X1(1)'=X2(1)
+ . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
+ . K EASDO2
+ G C4F2
+C4X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
+ S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X(1))
+ S:$D(X)#2 X(2)=X
+ S X=$G(X(1))
+ Q
+C4F2 S DIXR=231 D C4X2(U) K X2 M X2=X D C4X2("O") K X1 M X1=X
+ D
+ . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ K X M X=X2 D
+ . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ G C4F3
+C4X2(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
+ S X=$G(X(1))
+ Q
+C4F3 Q
+X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114
+ S DE(DW)="C5^DGRPTX4",DE(DW,"INDEX")=1
+ G RE
+C5 G C5S:$D(DE(5))[0 K DB
+ D ^DGRPTX5
+C5S S X="" G:DG(DQ)=X C5F1 K DB
+ D ^DGRPTX6
+C5F1 N X,X1,X2 S DIXR=234 D C5X1(U) K X2 M X2=X D C5X1("O") K X1 M X1=X
+ D
+ . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ K X M X=X2 D
+ . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ G C5F2
+C5X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4))
+ S X=$G(X(1))
+ Q
+C5F2 Q
+X5 K:$L(X)>15!($L(X)<2) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X6 S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131
+ Q
+7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115
+ S DE(DW)="C7^DGRPTX4",DE(DW,"INDEX")=1
+ S DU="DIC(5,"
+ G RE
+C7 G C7S:$D(DE(7))[0 K DB
+ D ^DGRPTX7
+C7S S X="" G:DG(DQ)=X C7F1 K DB
+ D ^DGRPTX8
+C7F1 N X,X1,X2 S DIXR=235 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X
+ D
+ . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ K X M X=X2 D
+ . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
+ G C7F2
+C7X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5))
+ S X=$G(X(1))
+ Q
+C7F2 Q
+X7 Q
+8 D:$D(DG)>9 F^DIE17 G ^DGRPTX9
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX5.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX5.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX5.m	(revision 623)
@@ -1,218 +1,3 @@
-DGRPTX5 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(9)=%
- I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,4) S:%]"" DE(2)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% S %=$P(%Z,U,7) S:%]"" DE(5)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,16) S:%]"" DE(8)=%
- I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(6)=% S %=$P(%Z,U,2) S:%]"" DE(7)=%
- I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,1) S:%]"" DE(10)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPTX5",DQ=1
-1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112
- S DQ(1,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
- S DE(DW)="C1^DGRPTX5",DE(DW,"INDEX")=1
- G RE
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
- S X=DE(1),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(1),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DE(1),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DE(1),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
- S X=DE(1),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DG(DQ),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C1F1 N X,X1,X2 S DIXR=185 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
- D
- . N DIEXARR M DIEXARR=X S DIEZCOND=1
- . I X1(1)'=X2(1)
- . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
- . K EASDO2
- G C1F2
-C1X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
- S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X(1))
- S:$D(X)#2 X(2)=X
- S X=$G(X(1))
- Q
-C1F2 S DIXR=231 D C1X2(U) K X2 M X2=X D C1X2("O") K X1 M X1=X
- D
- . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- K X M X=X2 D
- . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- G C1F3
-C1X2(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
- S X=$G(X(1))
- Q
-C1F3 Q
-X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
- I $D(X),X'?.ANP K X
- Q
- ;
-2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114
- S DE(DW)="C2^DGRPTX5",DE(DW,"INDEX")=1
- G RE
-C2 G C2S:$D(DE(2))[0 K DB
- S X=DE(2),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
- S X=DE(2),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(2),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DE(2),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DE(2),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
- S X=DE(2),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET
-C2S S X="" G:DG(DQ)=X C2F1 K DB
- S X=DG(DQ),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DG(DQ),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C2F1 N X,X1,X2 S DIXR=234 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X
- D
- . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- K X M X=X2 D
- . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- G C2F2
-C2X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4))
- S X=$G(X(1))
- Q
-C2F2 Q
-X2 K:$L(X)>15!($L(X)<2) X
- I $D(X),X'?.ANP K X
- Q
- ;
-3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X3 S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131
- Q
-4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115
- S DE(DW)="C4^DGRPTX5",DE(DW,"INDEX")=1
- S DU="DIC(5,"
- G RE
-C4 G C4S:$D(DE(4))[0 K DB
- S X=DE(4),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)
- S X=DE(4),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
- S X=DE(4),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(4),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DE(4),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DE(4),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
- S X=DE(4),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET
-C4S S X="" G:DG(DQ)=X C4F1 K DB
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
- S X=DG(DQ),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C4F1 N X,X1,X2 S DIXR=235 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
- D
- . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- K X M X=X2 D
- . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
- G C4F2
-C4X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5))
- S X=$G(X(1))
- Q
-C4F2 Q
-X4 Q
-5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117
- S DQ(5,2)="S Y(0)=Y Q:Y']""""  S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0  S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)"
- S DE(DW)="C5^DGRPTX5"
- G RE
-C5 G C5S:$D(DE(5))[0 K DB
+DGRPTX5 ; ;04/21/06
  S X=DE(5),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
@@ -220,84 +5,10 @@
  D EVENT^IVMPLOG(DA)
  S X=DE(5),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DE(5),DIC=DIE
  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
  S X=DE(5),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
+ S X=DE(5),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
  S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET
-C5S S X="" G:DG(DQ)=X C5F1 K DB
- D ^DGRPTX6
-C5F1 Q
-X5 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0))  S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC
- Q
- ;
-6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".13;1",DV="Fa",DU="",DLB="PHONE NUMBER [RESIDENCE]",DIFLD=.131
- S DE(DW)="C6^DGRPTX5"
- G RE
-C6 G C6S:$D(DE(6))[0 K DB
- D ^DGRPTX7
-C6S S X="" G:DG(DQ)=X C6F1 K DB
- D ^DGRPTX8
-C6F1 Q
-X6 K:$L(X)>20!($L(X)<4) X
- I $D(X),X'?.ANP K X
- Q
- ;
-7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".13;2",DV="Fa",DU="",DLB="PHONE NUMBER [WORK]",DIFLD=.132
- S DE(DW)="C7^DGRPTX5"
- G RE
-C7 G C7S:$D(DE(7))[0 K DB
- D ^DGRPTX9
-C7S S X="" G:DG(DQ)=X C7F1 K DB
- D ^DGRPTX10
-C7F1 Q
-X7 K:$L(X)>20!($L(X)<4) X
- I $D(X),X'?.ANP K X
- Q
- ;
-8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".11;16",DV="S",DU="",DLB="BAD ADDRESS INDICATOR",DIFLD=.121
- S DE(DW)="C8^DGRPTX5"
- S DU="1:UNDELIVERABLE;2:HOMELESS;3:OTHER;"
- G RE
-C8 G C8S:$D(DE(8))[0 K DB
- D ^DGRPTX11
-C8S S X="" G:DG(DQ)=X C8F1 K DB
- D ^DGRPTX12
-C8F1 Q
-X8 Q
-9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;5",DV="RP11'a",DU="",DLB="MARITAL STATUS",DIFLD=.05
- S DE(DW)="C9^DGRPTX5"
- S DU="DIC(11,"
- G RE
-C9 G C9S:$D(DE(9))[0 K DB
- D ^DGRPTX13
-C9S S X="" G:DG(DQ)=X C9F1 K DB
- D ^DGRPTX14
-C9F1 Q
-X9 Q
-10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".21;1",DV="Fa",DU="",DLB="K-NAME OF PRIMARY NOK",DIFLD=.211
- S DE(DW)="C10^DGRPTX5",DE(DW,"INDEX")=1
- G RE
-C10 G C10S:$D(DE(10))[0 K DB
- D ^DGRPTX15
-C10S S X="" G:DG(DQ)=X C10F1 K DB
- D ^DGRPTX16
-C10F1 N X,X1,X2 S DIXR=590 D C10X1(U) K X2 M X2=X D C10X1("O") K X1 M X1=X
- I $G(X(1))]"" D
- . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1 D DELCOMP^XLFNAME2(2,.DA,.211,1.02) Q
- K X M X=X2 I $G(X(1))]"" D
- . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1,DG20NAME=X D NARY^XLFNAME7(.DG20NAME),UPDCOMP^XLFNAME2(2,.DA,.211,.DG20NAME,1.02,+$P($G(^DPT(DA,"NAME")),U,2),"CL35") K DG20NAME Q
- G C10F2
-C10X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.211,DION),$P($G(^DPT(DA,.21)),U,1))
- S X=$G(X(1))
- Q
-C10F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=602 S DIEZRXR(2,DIXR)=""
- Q
-X10 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NAME)=$$FORMAT^XLFNAME7(.DG20NAME,3,35) K:'$L(X) X,DG20NAME
- I $D(X),X'?.ANP K X
- Q
- ;
-11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X11 S:X="" Y="@30"
- Q
-12 D:$D(DG)>9 F^DIE17 G ^DGRPTX17
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX6.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX6.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX6.m	(revision 623)
@@ -1,3 +1,3 @@
-DGRPTX6 ; ;12/13/08
+DGRPTX6 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
@@ -5,6 +5,10 @@
  D EVENT^IVMPLOG(DA)
  S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DG(DQ),DIC=DIE
  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
  S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
  I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX7.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX7.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX7.m	(revision 623)
@@ -1,12 +1,16 @@
-DGRPTX7 ; ;12/13/08
- S X=DE(6),DIC=DIE
+DGRPTX7 ; ;04/21/06
+ S X=DE(7),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)
+ S X=DE(7),DIC=DIE
+ S A1B2TAG="PAT" D ^A1B2XFR
+ S X=DE(7),DIC=DIE
  D EVENT^IVMPLOG(DA)
- S X=DE(6),DIC=DIE
+ S X=DE(7),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DE(7),DIC=DIE
  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DE(6),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
- S X=DE(6),DIC=DIE
+ S X=DE(7),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
+ S X=DE(7),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(6),DIC=DIE
- X "N % S %=$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30) K:%'="""" ^DPT(""AZVWVOE"",%,DA)"
- S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET
+ S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX8.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX8.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX8.m	(revision 623)
@@ -1,12 +1,16 @@
-DGRPTX8 ; ;12/13/08
+DGRPTX8 ; ;04/21/06
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ S A1B2TAG="PAT" D ^A1B2XFR
  S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
  S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
+ S X=DG(DQ),DIC=DIE
  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
  S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
  S X=DG(DQ),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DG(DQ),DIC=DIE
- X "N % S %=$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30) S:%'="""" ^DPT(""AZVWVOE"",%,DA)="""""
- I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+ I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX9.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX9.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX9.m	(revision 623)
@@ -1,10 +1,200 @@
-DGRPTX9 ; ;12/13/08
- S X=DE(7),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(7),DIC=DIE
- S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
- S X=DE(7),DIC=DIE
+DGRPTX9 ; ;04/21/06
+ D DE G BEGIN
+DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(5)=%
+ I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,7) S:%]"" DE(1)=% S %=$P(%Z,U,16) S:%]"" DE(4)=%
+ I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(2)=% S %=$P(%Z,U,2) S:%]"" DE(3)=%
+ I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,1) S:%]"" DE(6)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPTX9",DQ=1
+1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117
+ S DQ(1,2)="S Y(0)=Y Q:Y']""""  S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0  S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)"
+ S DE(DW)="C1^DGRPTX9"
+ G RE
+C1 G C1S:$D(DE(1))[0 K DB
+ S X=DE(1),DIC=DIE
+ S A1B2TAG="PAT" D ^A1B2XFR
+ S X=DE(1),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DE(1),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DE(1),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
+ S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S A1B2TAG="PAT" D ^A1B2XFR
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DG(DQ),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
+ I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C1F1 Q
+X1 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0))  S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC
+ Q
+ ;
+2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".13;1",DV="Fa",DU="",DLB="PHONE NUMBER [RESIDENCE]",DIFLD=.131
+ S DE(DW)="C2^DGRPTX9"
+ G RE
+C2 G C2S:$D(DE(2))[0 K DB
+ S X=DE(2),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DE(2),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DE(2),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
+ S X=DE(2),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET
+C2S S X="" G:DG(DQ)=X C2F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DG(DQ),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C2F1 Q
+X2 K:$L(X)>20!($L(X)<4) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".13;2",DV="Fa",DU="",DLB="PHONE NUMBER [WORK]",DIFLD=.132
+ S DE(DW)="C3^DGRPTX9"
+ G RE
+C3 G C3S:$D(DE(3))[0 K DB
+ S X=DE(3),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DE(3),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DE(3),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".132;" D AVAFC^VAFCDD01(DA)
- S X=DE(7),DIC=DIE
- D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
- S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET
+ S X=DE(3),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET
+C3S S X="" G:DG(DQ)=X C3F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DG(DQ),DIC=DIE
+ S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".132;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C3F1 Q
+X3 K:$L(X)>20!($L(X)<4) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;16",DV="S",DU="",DLB="BAD ADDRESS INDICATOR",DIFLD=.121
+ S DU="1:UNDELIVERABLE;2:HOMELESS;3:OTHER;"
+ G RE
+X4 Q
+5 S DW="0;5",DV="RP11'a",DU="",DLB="MARITAL STATUS",DIFLD=.05
+ S DE(DW)="C5^DGRPTX9"
+ S DU="DIC(11,"
+ G RE
+C5 G C5S:$D(DE(5))[0 K DB
+ S X=DE(5),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAFCDD01(DA)
+ S X=DE(5),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET
+C5S S X="" G:DG(DQ)=X C5F1 K DB
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C5F1 Q
+X5 Q
+6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".21;1",DV="Fa",DU="",DLB="K-NAME OF PRIMARY NOK",DIFLD=.211
+ S DE(DW)="C6^DGRPTX9",DE(DW,"INDEX")=1
+ G RE
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
+ X "S DGXRF=.211 D ^DGDDC Q"
+ S X=DE(6),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VAFCDD01(DA)
+ S X=DE(6),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET
+C6S S X="" G:DG(DQ)=X C6F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C6F1 N X,X1,X2 S DIXR=590 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
+ I $G(X(1))]"" D
+ . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1 D DELCOMP^XLFNAME2(2,.DA,.211,1.02) Q
+ K X M X=X2 I $G(X(1))]"" D
+ . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1,DG20NAME=X D NARY^XLFNAME7(.DG20NAME),UPDCOMP^XLFNAME2(2,.DA,.211,.DG20NAME,1.02,+$P($G(^DPT(DA,"NAME")),U,2),"CL35") K DG20NAME Q
+ G C6F2
+C6X1(DION) K X
+ S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.211,DION),$P($G(^DPT(DA,.21)),U,1))
+ S X=$G(X(1))
+ Q
+C6F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
+ Q
+X6 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NAME)=$$FORMAT^XLFNAME7(.DG20NAME,3,35) K:'$L(X) X,DG20NAME
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X7 S:X="" Y="@30"
+ Q
+8 D:$D(DG)>9 F^DIE17 G ^DGRPTX10
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m	(revision 623)
@@ -1,211 +1,211 @@
-DGRPU	;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;12/25/06  18:28
-	;;5.3;Registration;**33,114,489,624,672,689,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-H	;Screen Header
-	I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
-	I DGRPS=1.1 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
-	S X=$$SSNNM(DFN)
-	I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
-	S X="",$P(X,"=",80)="" W !,X Q
-	Q
-	;
-AL(DGLEN)	;DGLEN= Available length of line
-A	;Format address(es)
-	I '$D(DGLEN) N DGLEN S DGLEN=29
-	N DGX
-	F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S DGA(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2
-	I DGA2=1 S DGA(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2
-	S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),DGA(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
-	I ".33^.34^.211^.331^.311^.25^.21"[DGAD D
-	.F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I)
-	E  D
-	.I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q
-	.S DGX=$P(DGRP(DGAD),U,DGA1+11)
-	S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9)
-	S DGA(DGA2)=$E($P(DGA(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(DGA(DGA2),",",2)):",",1:"")_$P(DGA(DGA2),",",2)_" "_DGX
-	F I=0:0 S I=$O(DGA(I)) Q:'I  S DGA(I)=$E(DGA(I),1,DGLEN)
-	K DGA1,I,J
-	Q
-	;
-W	I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q
-	W ?X,@DGVI,Z,@DGVO
-	Q
-	;
-H1	;
-	;;PATIENT DEMOGRAPHIC DATA
-	;;PATIENT DATA
-	;;EMERGENCY CONTACT DATA
-	;;APPLICANT/SPOUSE EMPLOYMENT DATA
-	;;INSURANCE DATA
-	;;MILITARY SERVICE DATA
-	;;ELIGIBILITY STATUS DATA
-	;;FAMILY DEMOGRAPHIC DATA
-	;;INCOME SCREENING DATA
-	;;INELIGIBLE/MISSING DATA
-	;;ELIGIBILITY VERIFICATION DATA
-	;;ADMISSION INFORMATION
-	;;APPLICATION INFORMATION
-	;;APPOINTMENT INFORMATION
-	;;SPONSOR DEMOGRAPHIC INFORMATION
-	;
-	;
-INCOME(DFN,DGDT)	; compute income for veteran...if not in 408.21, pass back file 2 data
-	; (called by PTF)
-	;
-	;
-	;  Input:  DFN as IEN of PATIENT file
-	;          DGDT as date to return income as of
-	;
-	; Output:  total income (computed function)
-	;          (from 408.21 if available...otherwise from file 2)
-	;
-	;
-	N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0
-	D ALL^DGMTU21(DFN,"V",DGDT,"I")
-	S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I)
-	I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20)
-	Q DGTOT
-	;
-	;
-MTCOMP(DFN,DGDT)	; is current means test OR COPAY complete?
-	;
-	;  Input:  DFN as IEN of PATIENT file
-	;          DGDT as 'as of' date
-	;
-	; Output:  1 if means test/COPAY for year prior to DT passed is complete
-	;          0 otherwise
-	;          DGMTYPT 1=MT;2=CP;0=NONE
-	;
-	N COMP,MT,X,YR
-	S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT)
-	S DGMTYPT=+$P(MT,U,5)
-	S COMP=1
-	I DGMTYPT=1 D  ;MT
-	.I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
-	I DGMTYPT=2 D  ;CP
-	.I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
-	S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*10000<YR S COMP=0
-	Q COMP
-	;
-HLP1010	;* This is called by the Executable Help for Patient field #1010.159
-	;   (APPOINTMENT REQUEST ON 1010EZ)
-	W !!,"    Enter a 'Y' if the veteran applicant has requested an"
-	W !,"    appointment with a VA doctor or provider and wants to be"
-	W !,"    seen as soon as one becomes available  Enter a 'N'"
-	W !,"    if the veteran applicant has not requested an appointment."
-	W !!,"    This question may ONLY be entered ONCE for the veteran."
-	W !,"    The answer to this question CANNOT be changed after the"
-	W !,"    initial entry.",!
-	Q
-	;
-HLPCS	; * This is called by the Executable Help for Income Relation field #.1
-	Q:X="?"
-	N DIR,DGRDVAR
-	W !?8,"Enter in this field a Yes or No to indicate whether the veteran"
-	W !?8,"contributed any dollar amount to the child's support last calendar"
-	W !?8,"year.  The contributions do not have to be in regular set amounts."
-	W !?8,"For example, a veteran who paid a child's school tuition or"
-	W !?8,"medical bills would be contributing to the child's support.",!
-	W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
-	Q
-	;
-HLP1823	;*This is called by the Executable Help for Patient Relation field #.18
-	N DIR,DGRDVAR
-	W !?7,"Enter 'Y' if the child is currently 18 to 23 years old and the child"
-	W !?7,"attended school last calendar year.  Enter 'N' if the child is currently"
-	W !?7,"18 to 23 years old but the child did not attend school last calendar"
-	W !?7,"year.  Enter 'N' if the child is not currently 18 to 23 years old.",!
-	I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
-	Q
-	;
-HLPMLDS	;* This is called by the Executable Help for Patient field #.362
-	;   (DISABILITY RET. FROM MILITARY?)
-	N X,Y,DIR
-	W !!,"  Enter '0' or 'NO' if the veteran:"
-	W !,"    -- Is NOT retired from the military OR"
-	W !,"    -- Is retired from the military due to length of service AND"
-	W !,"       does NOT have a disability confirmed by the Military Branch"
-	W !,"       to have been incurred in or aggravated while on active duty."
-	W !!,"  Enter '1' or 'YES, RECEIVING MILITARY RETIREMENT' if the veteran:"
-	W !,"    -- Is confirmed by the Military Branch to have been discharged"
-	W !,"       or released due to a disability incurred in or aggravated"
-	W !,"       while on active duty AND"
-	W !,"       -- Has NOT filed a claim for VA compensation benefits OR"
-	W !,"       -- Has been rated by the VA to be NSC OR"
-	W !,"       -- Has been rated by the VA to have noncompensable 0%"
-	W !,"          SC conditions."
-	S DIR(0)="E" D ^DIR Q:+Y<1
-	W !!,"  Enter '2' or 'YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA"
-	W !,"                COMPENSATION' if the veteran:"
-	W !,"       -- Is confirmed by the Military Branch to have been discharged"
-	W !,"          or released due to a disability incurred in or aggravated"
-	W !,"          while on active duty AND"
-	W !,"       -- Is receiving military disability retirement pay AND"
-	W !,"       -- Has been rated by VA to have compensable SC conditions"
-	W !,"          but is NOT receiving compensation from the VA"
-	W !!,"          Once eligibility has been verified, this field will no longer"
-	W !,"          be editable to any user who does not hold the designated security"
-	W !,"          key."
-	Q
-HLP3602	;help text for field .3602, Rec'ing Disability in Lieu of VA Comp
-	W !,"     Enter 'Y' if this veteran applicant is receiving disability"
-	W !,"     retirement pay from the Military instead of VA compensation."
-	W !,"     Enter 'N' if this veteran applicant is not receiving disability"
-	W !,"     retirement pay from the Military instead of VA compensation."
-	W !,"     Once eligibility has been verified by HEC this field will no longer "
-	W !,"     be editable by VistA users. Send updates and/or requests to HEC."
-	Q
-HLP3603	;help text for field .3603, Discharge Due to LOD Disability
-	W !,"     Enter 'Y' if this veteran applicant was discharged from the"
-	W !,"     military for a disability incurred or aggravated in the line "
-	W !,"     of duty.  Enter 'N' if this veteran applicant was not discharged"
-	W !,"     from the military for a disability incurred or aggravated in the"
-	W !,"     line of duty. Once eligibility has been verified by HEC this field"
-	W !,"     will no longer be editable by VistA users. Send updates and/or requests"
-	W !,"     to HEC."
-	Q
-SSNNM(DFN)	; SSN and name on first line of screen
-	;
-	; ** start of VOE change: DAOU/JLG 2/1/2005,VA/CJS,WV/TOAD 5/9/2006 **
-	;
-	; Change code so it will display HRN if SSN is null
-	;
-	; before:
-	;
-	; N X,SSN
-	; S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
-	;
-	; after:
-	;
-	; Social Security Number field (.09) in Patient file (2)
-	N X,SSN,HRN
-	S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9)
-	I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
-	;
-ID	S SSN=$$ID^DGLBPID(DFN) ;**GFT/VW
-	; for IHS or EHR, replace SSN with HRN
-	I $G(DUZ("AG"))'="V" D
-	. Q:SSN]""
-	. S HRN=$$HRN^AUPNPAT3(+DFN,DUZ(2))
-	. I HRN S SSN="HRN-"_HRN
-	;
-	; ** end of VOE change **
-	;
-	S X=$P(X,U)_"; "_SSN
-	Q X
-	;
+DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;12/25/06  18:28
+ ;;5.3;Registration;**33,114,489,624,672,689,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+H ;Screen Header
+ I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
+ I DGRPS=1.1 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
+ S X=$$SSNNM(DFN)
+ I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
+ S X="",$P(X,"=",80)="" W !,X Q
+ Q
+ ;
+AL(DGLEN) ;DGLEN= Available length of line
+A ;Format address(es)
+ I '$D(DGLEN) N DGLEN S DGLEN=29
+ N DGX
+ F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S DGA(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2
+ I DGA2=1 S DGA(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2
+ S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),DGA(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
+ I ".33^.34^.211^.331^.311^.25^.21"[DGAD D
+ .F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I)
+ E  D
+ .I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q
+ .S DGX=$P(DGRP(DGAD),U,DGA1+11)
+ S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9)
+ S DGA(DGA2)=$E($P(DGA(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(DGA(DGA2),",",2)):",",1:"")_$P(DGA(DGA2),",",2)_" "_DGX
+ F I=0:0 S I=$O(DGA(I)) Q:'I  S DGA(I)=$E(DGA(I),1,DGLEN)
+ K DGA1,I,J
+ Q
+ ;
+W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q
+ W ?X,@DGVI,Z,@DGVO
+ Q
+ ;
+H1 ;
+ ;;PATIENT DEMOGRAPHIC DATA
+ ;;PATIENT DATA
+ ;;EMERGENCY CONTACT DATA
+ ;;APPLICANT/SPOUSE EMPLOYMENT DATA
+ ;;INSURANCE DATA
+ ;;MILITARY SERVICE DATA
+ ;;ELIGIBILITY STATUS DATA
+ ;;FAMILY DEMOGRAPHIC DATA
+ ;;INCOME SCREENING DATA
+ ;;INELIGIBLE/MISSING DATA
+ ;;ELIGIBILITY VERIFICATION DATA
+ ;;ADMISSION INFORMATION
+ ;;APPLICATION INFORMATION
+ ;;APPOINTMENT INFORMATION
+ ;;SPONSOR DEMOGRAPHIC INFORMATION
+ ;
+ ;
+INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data
+ ; (called by PTF)
+ ;
+ ;
+ ;  Input:  DFN as IEN of PATIENT file
+ ;          DGDT as date to return income as of
+ ;
+ ; Output:  total income (computed function)
+ ;          (from 408.21 if available...otherwise from file 2)
+ ;
+ ;
+ N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0
+ D ALL^DGMTU21(DFN,"V",DGDT,"I")
+ S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I)
+ I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20)
+ Q DGTOT
+ ;
+ ;
+MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete?
+ ;
+ ;  Input:  DFN as IEN of PATIENT file
+ ;          DGDT as 'as of' date
+ ;
+ ; Output:  1 if means test/COPAY for year prior to DT passed is complete
+ ;          0 otherwise
+ ;          DGMTYPT 1=MT;2=CP;0=NONE
+ ;
+ N COMP,MT,X,YR
+ S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT)
+ S DGMTYPT=+$P(MT,U,5)
+ S COMP=1
+ I DGMTYPT=1 D  ;MT
+ .I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
+ I DGMTYPT=2 D  ;CP
+ .I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
+ S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*10000<YR S COMP=0
+ Q COMP
+ ;
+HLP1010 ;* This is called by the Executable Help for Patient field #1010.159
+ ;   (APPOINTMENT REQUEST ON 1010EZ)
+ W !!,"    Enter a 'Y' if the veteran applicant has requested an"
+ W !,"    appointment with a VA doctor or provider and wants to be"
+ W !,"    seen as soon as one becomes available  Enter a 'N'"
+ W !,"    if the veteran applicant has not requested an appointment."
+ W !!,"    This question may ONLY be entered ONCE for the veteran."
+ W !,"    The answer to this question CANNOT be changed after the"
+ W !,"    initial entry.",!
+ Q
+ ;
+HLPCS ; * This is called by the Executable Help for Income Relation field #.1
+ Q:X="?"
+ N DIR,DGRDVAR
+ W !?8,"Enter in this field a Yes or No to indicate whether the veteran"
+ W !?8,"contributed any dollar amount to the child's support last calendar"
+ W !?8,"year.  The contributions do not have to be in regular set amounts."
+ W !?8,"For example, a veteran who paid a child's school tuition or"
+ W !?8,"medical bills would be contributing to the child's support.",!
+ W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
+ Q
+ ;
+HLP1823 ;*This is called by the Executable Help for Patient Relation field #.18
+ N DIR,DGRDVAR
+ W !?7,"Enter 'Y' if the child is currently 18 to 23 years old and the child"
+ W !?7,"attended school last calendar year.  Enter 'N' if the child is currently"
+ W !?7,"18 to 23 years old but the child did not attend school last calendar"
+ W !?7,"year.  Enter 'N' if the child is not currently 18 to 23 years old.",!
+ I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
+ Q
+ ;
+HLPMLDS ;* This is called by the Executable Help for Patient field #.362
+ ;   (DISABILITY RET. FROM MILITARY?)
+ N X,Y,DIR
+ W !!,"  Enter '0' or 'NO' if the veteran:"
+ W !,"    -- Is NOT retired from the military OR"
+ W !,"    -- Is retired from the military due to length of service AND"
+ W !,"       does NOT have a disability confirmed by the Military Branch"
+ W !,"       to have been incurred in or aggravated while on active duty."
+ W !!,"  Enter '1' or 'YES, RECEIVING MILITARY RETIREMENT' if the veteran:"
+ W !,"    -- Is confirmed by the Military Branch to have been discharged"
+ W !,"       or released due to a disability incurred in or aggravated"
+ W !,"       while on active duty AND"
+ W !,"       -- Has NOT filed a claim for VA compensation benefits OR"
+ W !,"       -- Has been rated by the VA to be NSC OR"
+ W !,"       -- Has been rated by the VA to have noncompensable 0%"
+ W !,"          SC conditions."
+ S DIR(0)="E" D ^DIR Q:+Y<1
+ W !!,"  Enter '2' or 'YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA"
+ W !,"                COMPENSATION' if the veteran:"
+ W !,"       -- Is confirmed by the Military Branch to have been discharged"
+ W !,"          or released due to a disability incurred in or aggravated"
+ W !,"          while on active duty AND"
+ W !,"       -- Is receiving military disability retirement pay AND"
+ W !,"       -- Has been rated by VA to have compensable SC conditions"
+ W !,"          but is NOT receiving compensation from the VA"
+ W !!,"          Once eligibility has been verified, this field will no longer"
+ W !,"          be editable to any user who does not hold the designated security"
+ W !,"          key."
+ Q
+HLP3602 ;help text for field .3602, Rec'ing Disability in Lieu of VA Comp
+ W !,"     Enter 'Y' if this veteran applicant is receiving disability"
+ W !,"     retirement pay from the Military instead of VA compensation."
+ W !,"     Enter 'N' if this veteran applicant is not receiving disability"
+ W !,"     retirement pay from the Military instead of VA compensation."
+ W !,"     Once eligibility has been verified by HEC this field will no longer "
+ W !,"     be editable by VistA users. Send updates and/or requests to HEC."
+ Q
+HLP3603 ;help text for field .3603, Discharge Due to LOD Disability
+ W !,"     Enter 'Y' if this veteran applicant was discharged from the"
+ W !,"     military for a disability incurred or aggravated in the line "
+ W !,"     of duty.  Enter 'N' if this veteran applicant was not discharged"
+ W !,"     from the military for a disability incurred or aggravated in the"
+ W !,"     line of duty. Once eligibility has been verified by HEC this field"
+ W !,"     will no longer be editable by VistA users. Send updates and/or requests"
+ W !,"     to HEC."
+ Q
+SSNNM(DFN) ; SSN and name on first line of screen
+ ;
+ ; ** start of VOE change: DAOU/JLG 2/1/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; Change code so it will display HRN if SSN is null
+ ;
+ ; before:
+ ;
+ ; N X,SSN
+ ; S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
+ ;
+ ; after:
+ ;
+ ; Social Security Number field (.09) in Patient file (2)
+ N X,SSN,HRN
+ S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9)
+ I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
+ ;
+ID S SSN=$$ID^DGLBPID(DFN) ;**GFT/VW
+ ; for IHS or EHR, replace SSN with HRN
+ I $G(DUZ("AG"))'="V" D
+ . Q:SSN]""
+ . S HRN=$$HRN^AUPNPAT3(+DFN,DUZ(2))
+ . I HRN S SSN="HRN-"_HRN
+ ;
+ ; ** end of VOE change **
+ ;
+ S X=$P(X,U)_"; "_SSN
+ Q X
+ ;
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPV.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPV.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPV.m	(revision 623)
@@ -1,141 +1,141 @@
-DGRPV	;ALB/MRL,RTK,PJR,BRM,TMK,AMA - REGISTRATION DEFINE VARIABLES ON ENTRY ; 8/11/05 12:56pm
-	;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-	;
-	;
-	;set up variables for registration screen processing
-	;
-	;DGRPVV   :string of 15 ones and zeros each character corresponding to
-	;          a particular screen (0 means allow edit, 1 means don't)
-	;
-	;DGRPVV(n):where n=screen number.  String of x ones and zeros where
-	;          x is the number of elements on screen n (0=edit, 1=don't)
-	;
-	;DGVI     :Turn on high intensity
-	;DGVO     :Turn off high intensity
-	;
-EN	D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS
-	S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity
-	I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X)
-M	I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
-	S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1)
-SC7	S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0
-	S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0
-	I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10"))
-	;
-	S DGPH=$P($G(^DPT(DFN,.53)),U)  ;Purple Heart Indicator
-	I $G(DGPRFLG)=1 D
-	. S DGRPVV="000001111111111"
-	E  D
-	. S DGRPVV="000000000000000"
-	S X="5^3^5^2^3^8^4^2^10^2^4^5^5^2^1"
-	;
-	; ** VOE change 1 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
-	;
-	; new line: if agency code is not VA, new section added to screen 3
-	I $G(DUZ("AG"))'="V" S $P(X,"^",3)="6"
-	;
-	; ** end of VOE change 1 **
-	;
-	F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J))
-	S DGRPVV(1.1)="00"
-	S DGRPVV(2)="00010"
-	I $G(DGPH)]"" S $E(DGRPVV(6),8)=1
-	;
-	F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
-	;
-	;-- if patient type is TRICARE then turn off screens 2,4
-	;
-	;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 
-	;-- commented the line to allow screens 2 & 4 to display for Tricare
-	;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
-	;
-	; ** VOE change 2 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
-	;
-	; add lines: if agency code is not VA, change last screen to 14,
-	; and clear flag for screen 15 (it is VA-specific)
-	I $G(DUZ("AG"))'="V" D
-	. S DGRPLAST=14
-	. F I=15 S DGRPVV=$E(DGRPVV,0,I-1)_$S(I=15:"",1:1)_$E(DGRPVV,I+1,99)
-	;
-	; ** end of VOE change 2 **
-	;
-	F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
-	I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99)
-	K DIRUT,DUOUT,DTOUT
-	;
-	;Fields are numbered screen_item and put in that piece position.
-	;Because FM does not allow more than 100 pieces on a node, it was
-	;necessary to start a new node E10 for fields on screens 10 or higher.
-	;In these instances, the piece position will be screen_item-100 so,
-	;for example, screen 11, item 2 would be field 112, but piece 12.
-	;Items on screens <10 will be found on node E.
-	;
-	F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
-	;
-	I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip
-	F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
-	S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob
-	;
-	; ** VOE change 3 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
-	;
-	; add line: if agency code is not VA, only edit one section of screen 7
-	; The rest is veteran specific.
-	I $G(DUZ("AG"))'="V" S DGRPVV(7)="1101"
-	;
-	; ** end of VOE change 3 **
-	;
-	I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
-	I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
-	;
-ELVER	;set up variables for eligibility verification
-	;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
-	;   and 11 if they're turned on).
-	;
-	S DGRP(.361)=$G(^DPT(DFN,.361))
-	I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10
-	I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=1000
-	S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
-	;
-	; ** VOE change 4 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
-	;
-	; add line: if agency code is not VA, and last screen is set to 15, set
-	; it to 14 (it is VA-specific)
-	I $G(DUZ("AG"))'="V",DGRPLAST=15 S DGRPLAST=14
-	;
-	; ** end of VOE change 4 **
-	;
-	I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I
-Q	K DGRPSC,DGRPSCE
-	Q
-	;
-WW	;Write number on screens for display and/or edit (Z=number)
-	W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
-	I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
-	I 'DGRPCM&($E(Z)'="[") W Z
-	Q
-	;
-WW1	;spacing for screen display (Z=item to print)
-	F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
-	W Z K Z2
-	Q
-	;
-WW2	; Write number on screen for fields always selectable
-	W:DGRPW ! S Z="["_Z_"]"
-	I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
-	Q
+DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA - REGISTRATION DEFINE VARIABLES ON ENTRY ; 8/11/05 12:56pm
+ ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ;
+ ;set up variables for registration screen processing
+ ;
+ ;DGRPVV   :string of 15 ones and zeros each character corresponding to
+ ;          a particular screen (0 means allow edit, 1 means don't)
+ ;
+ ;DGRPVV(n):where n=screen number.  String of x ones and zeros where
+ ;          x is the number of elements on screen n (0=edit, 1=don't)
+ ;
+ ;DGVI     :Turn on high intensity
+ ;DGVO     :Turn off high intensity
+ ;
+EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS
+ S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity
+ I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X)
+M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
+ S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1)
+SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0
+ S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0
+ I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10"))
+ ;
+ S DGPH=$P($G(^DPT(DFN,.53)),U)  ;Purple Heart Indicator
+ I $G(DGPRFLG)=1 D
+ . S DGRPVV="000001111111111"
+ E  D
+ . S DGRPVV="000000000000000"
+ S X="5^3^5^2^3^8^4^2^10^2^4^5^5^2^1"
+ ;
+ ; ** VOE change 1 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; new line: if agency code is not VA, new section added to screen 3
+ I $G(DUZ("AG"))'="V" S $P(X,"^",3)="6"
+ ;
+ ; ** end of VOE change 1 **
+ ;
+ F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J))
+ S DGRPVV(1.1)="00"
+ S DGRPVV(2)="00010"
+ I $G(DGPH)]"" S $E(DGRPVV(6),8)=1
+ ;
+ F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
+ ;
+ ;-- if patient type is TRICARE then turn off screens 2,4
+ ;
+ ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 
+ ;-- commented the line to allow screens 2 & 4 to display for Tricare
+ ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
+ ;
+ ; ** VOE change 2 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; add lines: if agency code is not VA, change last screen to 14,
+ ; and clear flag for screen 15 (it is VA-specific)
+ I $G(DUZ("AG"))'="V" D
+ . S DGRPLAST=14
+ . F I=15 S DGRPVV=$E(DGRPVV,0,I-1)_$S(I=15:"",1:1)_$E(DGRPVV,I+1,99)
+ ;
+ ; ** end of VOE change 2 **
+ ;
+ F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
+ I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99)
+ K DIRUT,DUOUT,DTOUT
+ ;
+ ;Fields are numbered screen_item and put in that piece position.
+ ;Because FM does not allow more than 100 pieces on a node, it was
+ ;necessary to start a new node E10 for fields on screens 10 or higher.
+ ;In these instances, the piece position will be screen_item-100 so,
+ ;for example, screen 11, item 2 would be field 112, but piece 12.
+ ;Items on screens <10 will be found on node E.
+ ;
+ F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
+ ;
+ I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip
+ F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
+ S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob
+ ;
+ ; ** VOE change 3 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; add line: if agency code is not VA, only edit one section of screen 7
+ ; The rest is veteran specific.
+ I $G(DUZ("AG"))'="V" S DGRPVV(7)="1101"
+ ;
+ ; ** end of VOE change 3 **
+ ;
+ I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
+ I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
+ ;
+ELVER ;set up variables for eligibility verification
+ ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
+ ;   and 11 if they're turned on).
+ ;
+ S DGRP(.361)=$G(^DPT(DFN,.361))
+ I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10
+ I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=1000
+ S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
+ ;
+ ; ** VOE change 4 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; add line: if agency code is not VA, and last screen is set to 15, set
+ ; it to 14 (it is VA-specific)
+ I $G(DUZ("AG"))'="V",DGRPLAST=15 S DGRPLAST=14
+ ;
+ ; ** end of VOE change 4 **
+ ;
+ I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I
+Q K DGRPSC,DGRPSCE
+ Q
+ ;
+WW ;Write number on screens for display and/or edit (Z=number)
+ W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
+ I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
+ I 'DGRPCM&($E(Z)'="[") W Z
+ Q
+ ;
+WW1 ;spacing for screen display (Z=item to print)
+ F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
+ W Z K Z2
+ Q
+ ;
+WW2 ; Write number on screen for fields always selectable
+ W:DGRPW ! S Z="["_Z_"]"
+ I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX7.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX7.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX7.m	(revision 623)
@@ -1,8 +1,6 @@
-DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLATE(#420), FILE 2;12/13/08
+DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLATE(#420), FILE 2;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(.29)) S %Z=^(.29) S %=$P(%Z,U,1) S:%]"" DE(14)=% S %=$P(%Z,U,2) S:%]"" DE(13)=% S %=$P(%Z,U,12) S:%]"" DE(11)=%
  I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(5)=% S %=$P(%Z,U,2) S:%]"" DE(7)=% S %=$P(%Z,U,4) S:%]"" DE(8)=% S %=$P(%Z,U,5) S:%]"" DE(9)=% S %=$P(%Z,U,12) S:%]"" DE(10)=%
- I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,3) S:%]"" DE(15)=% S %=$P(%Z,U,4) S:%]"" DE(16)=%
  I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(2)=%
  I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(4)=%
@@ -60,5 +58,5 @@
 X1 S:DGDR'["701" Y="@702"
  Q
-2 S DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391
+2 S DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391
  S DE(DW)="C2^DGRPX7",DE(DW,"INDEX")=1
  S DU="DG(391,"
@@ -87,5 +85,5 @@
 X3 D SC7^DGRPV
  Q
-4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
+4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
  S DE(DW)="C4^DGRPX7"
  S DU="Y:YES;N:NO;"
@@ -123,5 +121,5 @@
  Q
  ;
-5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".3;1",DV="SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301
+5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301
  S DE(DW)="C5^DGRPX7"
  S DU="Y:YES;N:NO;"
@@ -206,13 +204,7 @@
  G RE
 C9 G C9S:$D(DE(9))[0 K DB
- S X=DE(9),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- S X=DE(9),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
+ D ^DGRPX71
 C9S S X="" G:DG(DQ)=X C9F1 K DB
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
+ D ^DGRPX72
 C9F1 Q
 X9 Q
@@ -222,61 +214,3 @@
  Q
  ;
-11 S DW=".29;12",DV="S",DU="",DLB="RATED INCOMPETENT?",DIFLD=.293
- S DE(DW)="C11^DGRPX7"
- S DU="0:NO;1:YES;"
- G RE
-C11 G C11S:$D(DE(11))[0 K DB
- S X=DE(11),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C11S S X="" G:DG(DQ)=X C11F1 K DB
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C11F1 Q
-X11 Q
-12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X12 S:'X Y=.313
- Q
-13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".29;2",DV="D",DU="",DLB="DATE RULED INCOMPETENT (CIVIL)",DIFLD=.292
- G RE
-X13 S %DT="E" D ^%DT S X=Y K:Y<1 X
- Q
- ;
-14 S DW=".29;1",DV="D",DU="",DLB="DATE RULED INCOMPETENT (VA)",DIFLD=.291
- G RE
-X14 S %DT="E" D ^%DT S X=Y K:Y<1 X
- Q
- ;
-15 S DW=".31;3",DV="FXOa",DU="",DLB="CLAIM NUMBER",DIFLD=.313
- S DQ(15,2)="S Y(0)=Y S Y=$E(Y,1,10)"
- S DE(DW)="C15^DGRPX7"
- G RE
-C15 G C15S:$D(DE(15))[0 K DB
- S X=DE(15),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA)
- S X=DE(15),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(15),DIIX=2_U_DIFLD D AUDIT^DIET
-C15S S X="" G:DG(DQ)=X C15F1 K DB
- D ^DGRPX71
-C15F1 Q
-X15 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E "  ",L S:X?1"SS".E X=L K:$L(X)>9 X Q:'$D(X)  I X'=L K:$L(X)>8!($L(X)<7)!'(X?.N) X
- I $D(X),X'?.ANP K X
- Q
- ;
-16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".31;4",DV="*P4'X",DU="",DLB="CLAIM FOLDER LOCATION",DIFLD=.314
- S DE(DW)="C16^DGRPX7"
- S DU="DIC(4,"
- G RE
-C16 G C16S:$D(DE(16))[0 K DB
- D ^DGRPX72
-C16S S X="" G:DG(DQ)=X C16F1 K DB
- D ^DGRPX73
-C16F1 Q
-X16 S DIC("S")="I $$CFLTF^DGREGDD(Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
- Q
- ;
-17 S DQ=18 ;@702
-18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X18 S:DGDR'["702" Y="@703"
- Q
-19 D:$D(DG)>9 F^DIE17 G ^DGRPX74
+11 D:$D(DG)>9 F^DIE17 G ^DGRPX73
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX71.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX71.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX71.m	(revision 623)
@@ -1,6 +1,5 @@
-DGRPX71 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
- I $D(DE(15))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+DGRPX71 ; ;12/27/07
+ S X=DE(9),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DE(9),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX72.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX72.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX72.m	(revision 623)
@@ -1,3 +1,5 @@
-DGRPX72 ; ;12/13/08
- S X=DE(16),DIC=DIE
- D KILL^DGREGDD(DA)
+DGRPX72 ; ;12/27/07
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+ S X=DG(DQ),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX73.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX73.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX73.m	(revision 623)
@@ -1,3 +1,209 @@
-DGRPX73 ; ;12/13/08
+DGRPX73 ; ;12/27/07
+ D DE G BEGIN
+DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
+ I $D(^(.29)) S %Z=^(.29) S %=$P(%Z,U,1) S:%]"" DE(4)=% S %=$P(%Z,U,2) S:%]"" DE(3)=% S %=$P(%Z,U,12) S:%]"" DE(1)=%
+ I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(12)=%
+ I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,3) S:%]"" DE(5)=% S %=$P(%Z,U,4) S:%]"" DE(6)=%
+ I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(9)=% S %=$P(%Z,U,13) S:%]"" DE(10)=% S %=$P(%Z,U,14) S:%]"" DE(11)=% S %=$P(%Z,U,20) S:%]"" DE(14)=%
+ K %Z Q
+ ;
+W W !?DL+DL-2,DLB_": "
+ Q
+O D W W Y W:$X>45 !?9
+ I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
+ W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
+TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
+ Q
+A K DQ(DQ) S DQ=DQ+1
+B G @DQ
+RE G PR:$D(DE(DQ)) D W,TR
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
+RD G QS:X?."?" I X["^" D D G ^DIE17
+ I X="@" D D G Z^DIE2
+ I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
+T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
+ K DDER G X
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
+ G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
+ I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
+V D @("X"_DQ) K YS
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
+ S X="?BAD"
+QS S DZ=X D D,QQ^DIEQ G B
+D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
+Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
+PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
+R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
+ I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
+ X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
+RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
+I I DV'["I",DV'["#" G RD
+ D E^DIE0 G RD:$D(X),PR
+ Q
+SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
+ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
+ D ^DIR I 'DDER S %=Y(0),X=Y
+ Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
+BEGIN S DNM="DGRPX73",DQ=1
+1 S DW=".29;12",DV="S",DU="",DLB="RATED INCOMPETENT?",DIFLD=.293
+ S DE(DW)="C1^DGRPX73"
+ S DU="0:NO;1:YES;"
+ G RE
+C1 G C1S:$D(DE(1))[0 K DB
+ S X=DE(1),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C1S S X="" G:DG(DQ)=X C1F1 K DB
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+C1F1 Q
+X1 Q
+2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X2 S:'X Y=.313
+ Q
+3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".29;2",DV="D",DU="",DLB="DATE RULED INCOMPETENT (CIVIL)",DIFLD=.292
+ G RE
+X3 S %DT="E" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;
+4 S DW=".29;1",DV="D",DU="",DLB="DATE RULED INCOMPETENT (VA)",DIFLD=.291
+ G RE
+X4 S %DT="E" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;
+5 S DW=".31;3",DV="FXOa",DU="",DLB="CLAIM NUMBER",DIFLD=.313
+ S DQ(5,2)="S Y(0)=Y S Y=$E(Y,1,10)"
+ S DE(DW)="C5^DGRPX73"
+ G RE
+C5 G C5S:$D(DE(5))[0 K DB
+ S X=DE(5),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA)
+ S X=DE(5),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET
+C5S S X="" G:DG(DQ)=X C5F1 K DB
+ S X=DG(DQ),DIC=DIE
+ I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ D EVENT^IVMPLOG(DA)
+ I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C5F1 Q
+X5 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E "  ",L S:X?1"SS".E X=L K:$L(X)>9 X Q:'$D(X)  I X'=L K:$L(X)>8!($L(X)<7)!'(X?.N) X
+ I $D(X),X'?.ANP K X
+ Q
+ ;
+6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".31;4",DV="*P4'X",DU="",DLB="CLAIM FOLDER LOCATION",DIFLD=.314
+ S DE(DW)="C6^DGRPX73"
+ S DU="DIC(4,"
+ G RE
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
+ D KILL^DGREGDD(DA)
+C6S S X="" G:DG(DQ)=X C6F1 K DB
  S X=DG(DQ),DIC=DIE
  D SET^DGREGDD(DA,X)
+C6F1 Q
+X6 S DIC("S")="I $$CFLTF^DGREGDD(Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
+ Q
+ ;
+7 S DQ=8 ;@702
+8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X8 S:DGDR'["702" Y="@703"
+ Q
+9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205
+ S DE(DW)="C9^DGRPX73"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
+C9 G C9S:$D(DE(9))[0 K DB
+ S X=DE(9),DIC=DIE
+ X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4)
+ S X=DE(9),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DE(9),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4)
+ S X=DE(9),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C9S S X="" G:DG(DQ)=X C9F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C9F1 Q
+X9 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
+ Q
+ ;
+10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215
+ S DE(DW)="C10^DGRPX73"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
+C10 G C10S:$D(DE(10))[0 K DB
+ S X=DE(10),DIC=DIE
+ X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4)
+ S X=DE(10),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DE(10),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4)
+ S X=DE(10),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C10S S X="" G:DG(DQ)=X C10F1 K DB
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4)
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
+C10F1 Q
+X10 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
+ Q
+ ;
+11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235
+ S DE(DW)="C11^DGRPX73"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
+C11 G C11S:$D(DE(11))[0 K DB
+ D ^DGRPX74
+C11S S X="" G:DG(DQ)=X C11F1 K DB
+ D ^DGRPX75
+C11F1 Q
+X11 S DFN=DA D MV^DGLOCK
+ Q
+ ;
+12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025
+ S DE(DW)="C12^DGRPX73"
+ S DU="Y:YES;N:NO;U:UNKNOWN;"
+ G RE
+C12 G C12S:$D(DE(12))[0 K DB
+ D ^DGRPX76
+C12S S X="" G:DG(DQ)=X C12F1 K DB
+ D ^DGRPX77
+C12F1 Q
+X12 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1
+ Q
+ ;
+13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X13 S:(X'="Y")&($P($G(^DPT(DA,.362)),U,12,14)'["Y") Y=.36265
+ Q
+14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".362;20",DV="NJ8,2X",DU="",DLB="TOTAL ANNUAL VA CHECK AMOUNT",DIFLD=.36295
+ S DE(DW)="C14^DGRPX73"
+ G RE
+C14 G C14S:$D(DE(14))[0 K DB
+ D ^DGRPX78
+C14S S X="" G:DG(DQ)=X C14F1 K DB
+ D ^DGRPX79
+C14F1 Q
+X14 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>99999)!(X<0) X I $D(X) S DFN=DA D MV^DGLOCK I $D(X),('$$TOTCHK^DGLOCK2(DFN)) D TOTCKMSG^DGLOCK2 K X
+ Q
+ ;
+15 D:$D(DG)>9 F^DIE17 G ^DGRPX710
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX74.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX74.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX74.m	(revision 623)
@@ -1,221 +1,9 @@
-DGRPX74 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,9) S:%]"" DE(14)=% S %=$P(%Z,U,11) S:%]"" DE(4)=%
- I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(12)=%
- I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,6) S:%]"" DE(9)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(2)=% S %=$P(%Z,U,14) S:%]"" DE(3)=% S %=$P(%Z,U,17) S:%]"" DE(7)=% S %=$P(%Z,U,20) S:%]"" DE(6)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPX74",DQ=1
-1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205
- S DE(DW)="C1^DGRPX74"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4)
- S X=DE(1),DIC=DIE
+DGRPX74 ; ;12/27/07
+ S X=DE(11),DIC=DIE
+ X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4)
+ S X=DE(11),DIC=DIE
  S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DE(1),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4)
- S X=DE(1),DIC=DIE
+ S X=DE(11),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4)
+ S X=DE(11),DIC=DIE
  D AUTOUPD^DGENA2(DA)
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C1F1 Q
-X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
- Q
- ;
-2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215
- S DE(DW)="C2^DGRPX74"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C2 G C2S:$D(DE(2))[0 K DB
- S X=DE(2),DIC=DIE
- X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4)
- S X=DE(2),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DE(2),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4)
- S X=DE(2),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C2S S X="" G:DG(DQ)=X C2F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C2F1 Q
-X2 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK
- Q
- ;
-3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235
- S DE(DW)="C3^DGRPX74"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C3 G C3S:$D(DE(3))[0 K DB
- S X=DE(3),DIC=DIE
- X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4)
- S X=DE(3),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DE(3),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4)
- S X=DE(3),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C3S S X="" G:DG(DQ)=X C3F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4)
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C3F1 Q
-X3 S DFN=DA D MV^DGLOCK
- Q
- ;
-4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025
- S DE(DW)="C4^DGRPX74"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C4 G C4S:$D(DE(4))[0 K DB
- S X=DE(4),DIC=DIE
- X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4)
- S X=DE(4),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4)
- S X=DE(4),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C4S S X="" G:DG(DQ)=X C4F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4)
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
-C4F1 Q
-X4 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1
- Q
- ;
-5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X5 S:(X'="Y")&($P($G(^DPT(DA,.362)),U,12,14)'["Y") Y=.36265
- Q
-6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".362;20",DV="NJ8,2X",DU="",DLB="TOTAL ANNUAL VA CHECK AMOUNT",DIFLD=.36295
- S DE(DW)="C6^DGRPX74"
- G RE
-C6 G C6S:$D(DE(6))[0 K DB
- S X=DE(6),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
- S X=DE(6),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C6S S X="" G:DG(DQ)=X C6F1 K DB
- S X=DG(DQ),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
-C6F1 Q
-X6 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>99999)!(X<0) X I $D(X) S DFN=DA D MV^DGLOCK I $D(X),('$$TOTCHK^DGLOCK2(DFN)) D TOTCKMSG^DGLOCK2 K X
- Q
- ;
-7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".362;17",DV="SX",DU="",DLB="GI INSURANCE POLICY?",DIFLD=.36265
- S DE(DW)="C7^DGRPX74"
- S DU="Y:YES;N:NO;U:UNKNOWN;"
- G RE
-C7 G C7S:$D(DE(7))[0 K DB
- S X=DE(7),DIC=DIE
- X ^DD(2,.36265,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(2,.36265,1,1,2.4)
-C7S S X="" G:DG(DQ)=X C7F1 K DB
- S X=DG(DQ),DIC=DIE
- X ^DD(2,.36265,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(2,.36265,1,1,1.4)
-C7F1 Q
-X7 S DFN=DA D MV^DGLOCK Q
- Q
- ;
-8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X8 S:X'="Y" Y="@703"
- Q
-9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".362;6",DV="NJ8,2X",DU="",DLB="AMOUNT OF GI INSURANCE",DIFLD=.3626
- G RE
-X9 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>999999)!(X<1) X I $D(X) S DFN=DA D MV^DGLOCK I $D(X),$D(^DPT(DA,.362)),$P(^(.362),U,17)'="Y" W !?4,*7,"Applicant doesn't have GI Insurance." K X
- Q
- ;
-10 S DQ=11 ;@703
-11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X11 S:DGDR'["703" Y="@704"
- Q
-12 S DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361
- S DE(DW)="C12^DGRPX74"
- S DU="DIC(8,"
- G RE
-C12 G C12S:$D(DE(12))[0 K DB
- D ^DGRPX75
-C12S S X="" G:DG(DQ)=X C12F1 K DB
- D ^DGRPX76
-C12F1 Q
-X12 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1
- Q
- ;
-13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X13 D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361
- Q
-14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".3;9",DV="*P35'X",DU="",DLB="AGENCY/ALLIED COUNTRY",DIFLD=.309
- S DU="DIC(35,"
- G RE
-X14 S DFN=DA D AAC^DGLOCK2
- Q
- ;
-15 D:$D(DG)>9 F^DIE17 G ^DGRPX77
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX75.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX75.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX75.m	(revision 623)
@@ -1,12 +1,9 @@
-DGRPX75 ; ;12/13/08
- S X=DE(12),DIC=DIE
- ;
- S X=DE(12),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK
- S X=DE(12),DIC=DIE
- X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q"
- S X=DE(12),DIC=DIE
- K ^DPT("AEL",DA,+X)
- S X=DE(12),DIC=DIE
+DGRPX75 ; ;12/27/07
+ S X=DG(DQ),DIC=DIE
+ X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4)
+ S X=DG(DQ),DIC=DIE
+ S DFN=DA D EN^DGMTCOR K DGMTCOR
+ S X=DG(DQ),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4)
+ S X=DG(DQ),DIC=DIE
  D AUTOUPD^DGENA2(DA)
- S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX76.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX76.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX76.m	(revision 623)
@@ -1,12 +1,7 @@
-DGRPX76 ; ;12/13/08
- S X=DG(DQ),DIC=DIE
- X "S DFN=DA D EN^DGMTR K DGREQF"
- S X=DG(DQ),DIC=DIE
- K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- S ^DPT("AEL",DA,+X)=""
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA)
- I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+DGRPX76 ; ;12/27/07
+ S X=DE(12),DIC=DIE
+ X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4)
+ S X=DE(12),DIC=DIE
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4)
+ S X=DE(12),DIC=DIE
+ D EVENT^IVMPLOG(DA)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX77.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX77.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX77.m	(revision 623)
@@ -1,134 +1,7 @@
-DGRPX77 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
- I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,3) S:%]"" DE(2)=%
- I $D(^("ODS")) S %Z=^("ODS") S %=$P(%Z,U,2) S:%]"" DE(4)=% S %=$P(%Z,U,3) S:%]"" DE(5)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPX77",DQ=1
-1 S D=0 K DE(1) ;361
- S DIFLD=361,DGO="^DGRPX78",DC="3^2.0361IP^E^",DV="2.0361M*P8'X",DW="0;1",DOW="ELIGIBILITY",DLB="Select "_DOW S:D DC=DC_D
- S DU="DIC(8,"
- G RE:D I $D(DSC(2.0361))#2,$P(DSC(2.0361),"I $D(^UTILITY(",1)="" X DSC(2.0361) S D=$O(^(0)) S:D="" D=-1 G M1
- S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
-M1 I D>0 S DC=DC_D I $D(^DPT(DA,"E",+D,0)) S DE(1)=$P(^(0),U,1)
- G RE
-R1 D DE
- S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),1:1) G 1+1
- ;
-2 S DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVICE",DIFLD=.323
- S DE(DW)="C2^DGRPX77"
- S DU="DIC(21,"
- G RE
-C2 G C2S:$D(DE(2))[0 K DB
- S X=DE(2),DIC=DIE
- K ^DPT("APOS",$E(X,1,30),DA)
- S X=DE(2),DIC=DIE
- ;
- S X=DE(2),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
- S X=DE(2),DIC=DIE
- D EVENT^IVMPLOG(DA)
- S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET
-C2S S X="" G:DG(DQ)=X C2F1 K DB
+DGRPX77 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
- S ^DPT("APOS",$E(X,1,30),DA)=""
+ X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4)
  S X=DG(DQ),DIC=DIE
- X ^DD(2,.323,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,"ODS")):^("ODS"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(2,.323,1,2,1.1) X ^DD(2,.323,1,2,1.4)
- S X=DG(DQ),DIC=DIE
- I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
+ K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4)
  S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
- I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C2F1 Q
-X2 S DFN=DA D POS^DGLOCK1
- Q
- ;
-3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X3 D ^DGYZODS S:'DGODS Y="@704"
- Q
-4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="ODS;2",DV="S",DU="",DLB="RECALLED TO ACTIVE DUTY",DIFLD=11500.02
- S DE(DW)="C4^DGRPX77"
- S DU="0:NO;1:NATIONAL GUARD;2:RESERVES;"
- G RE
-C4 G C4S:$D(DE(4))[0 K DB
- S X=DE(4),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
-C4S S X="" G:DG(DQ)=X C4F1 K DB
- S X=DG(DQ),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
-C4F1 Q
-X4 Q
-5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="ODS;3",DV="*P25002.1'",DU="",DLB="RANK",DIFLD=11500.03
- S DE(DW)="C5^DGRPX77"
- S DU="DIC(25002.1,"
- G RE
-C5 G C5S:$D(DE(5))[0 K DB
- S X=DE(5),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
-C5S S X="" G:DG(DQ)=X C5F1 K DB
- S X=DG(DQ),DIC=DIE
- S A1B2TAG="PAT" D ^A1B2XFR
-C5F1 Q
-X5 S DIC("S")="I '$P(^(0),""^"",4),(""^e^c^""[(""^""_$P(^(0),""^"",2)_""^""))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
- Q
- ;
-6 S DQ=7 ;@704
-7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X7 S:DGDR'["704" Y="@99"
- Q
-8 D:$D(DG)>9 F^DIE17,DE S DQ=8,D=0 K DE(1) ;.3731
- S DIFLD=.3731,DGO="^DGRPX79",DC="2^2.05A^.373^",DV="2.05MFX",DW="0;1",DOW="SERVICE CONNECTED CONDITIONS",DLB="Select "_DOW S:D DC=DC_D
- G RE:D I $D(DSC(2.05))#2,$P(DSC(2.05),"I $D(^UTILITY(",1)="" X DSC(2.05) S D=$O(^(0)) S:D="" D=-1 G M8
- S D=$S($D(^DPT(DA,.373,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
-M8 I D>0 S DC=DC_D I $D(^DPT(DA,.373,+D,0)) S DE(8)=$P(^(0),U,1)
- G RE
-R8 D DE
- S D=$S($D(^DPT(DA,.373,0)):$P(^(0),U,3,4),1:1) G 8+1
- ;
-9 S DQ=10 ;@99
-10 G 0^DIE17
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX78.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX78.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX78.m	(revision 623)
@@ -1,82 +1,5 @@
-DGRPX78 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPX78",DQ=1+D G B
-1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD=.01
- S DE(DW)="C1^DGRPX78"
- S DU="DIC(8,"
- G RE:'D S DQ=2 G 2
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- K ^DPT(DA(1),"E","B",$E(X,1,30),DA)
- S X=DE(1),DIC=DIE
- K ^DPT("AEL",DA(1),+X)
- S X=DE(1),DIC=DIE
- D E32^VADPT62
- S X=DE(1),DIC=DIE
- X "S DFN=DA(1) D EN^DGMTR K DGREQF"
- S X=DE(1),DIC=DIE
- D AUTOUPD^DGENA2(DA(1))
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^DPT(DA(1),"E","B",$E(X,1,30),DA)=""
- S X=DG(DQ),DIC=DIE
- S ^DPT("AEL",DA(1),+X)=""
- S X=DG(DQ),DIC=DIE
- D E31^VADPT62
- S X=DG(DQ),DIC=DIE
- X "S DFN=DA(1) D EN^DGMTR K DGREQF"
- S X=DG(DQ),DIC=DIE
- D AUTOUPD^DGENA2(DA(1))
-C1F1 Q
-X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) S DINUM=X
- Q
- ;
-2 G 1^DIE17
+DGRPX78 ; ;12/27/07
+ S X=DE(14),DIC=DIE
+ X "S DFN=DA D EN^DGMTR K DGREQF"
+ S X=DE(14),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX79.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX79.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX79.m	(revision 623)
@@ -1,63 +1,5 @@
-DGRPX79 ; ;12/13/08
- D DE G BEGIN
-DE S DIE="^DPT(D0,.373,",DIC=DIE,DP=2.05,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.373,DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="DGRPX79",DQ=1+D G B
-1 S DW="0;1",DV="MFX",DU="",DLB="SERVICE CONNECTED CONDITIONS",DIFLD=.01
- G RE:'D S DQ=2 G 2
-X1 K:$L(X)>30!($L(X)<1) X
- I $D(X),X'?.ANP K X
- Q
- ;
-2 S DW="0;2",DV="NJ3,0X",DU="",DLB="PERCENTAGE",DIFLD=.02
- G RE
-X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X
- Q
- ;
-3 G 1^DIE17
+DGRPX79 ; ;12/27/07
+ S X=DG(DQ),DIC=DIE
+ X "S DFN=DA D EN^DGMTR K DGREQF"
+ S X=DG(DQ),DIC=DIE
+ D AUTOUPD^DGENA2(DA)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPXR.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPXR.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPXR.m	(revision 623)
@@ -1,3 +1,3 @@
-DGRPXR ; GENERATED FROM 'DGRP COLLATERAL REGISTER' INPUT TEMPLATE(#422), FILE 2;12/13/08
+DGRPXR ; GENERATED FROM 'DGRP COLLATERAL REGISTER' INPUT TEMPLATE(#422), FILE 2;12/10/01
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -55,5 +55,5 @@
  M DIEZAR=^DIE(422,"AR") S DICRREC="TRIG^DIE17"
  S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=422,U="^"
-1 S DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
+1 S DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
  S DE(DW)="C1^DGRPXR"
  S DU="Y:YES;N:NO;"
@@ -66,6 +66,4 @@
  S DFN=DA D EN^DGMTCOR K DGMTCOR
  S X=DE(1),DIC=DIE
- S DFN=DA D EN^DGRP7CC
- S X=DE(1),DIC=DIE
  ;
  S X=DE(1),DIC=DIE
@@ -76,9 +74,7 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
  S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
-C1S S X="" G:DG(DQ)=X C1F1 K DB
+C1S S X="" Q:DG(DQ)=X  K DB
  S X=DG(DQ),DIC=DIE
  S DFN=DA D EN^DGMTCOR K DGMTCOR
- S X=DG(DQ),DIC=DIE
- S DFN=DA D EN^DGRP7CC
  S X=DG(DQ),DIC=DIE
  X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4)
@@ -90,5 +86,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
  I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C1F1 Q
+ Q
 X1 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK
  Q
@@ -113,5 +109,5 @@
  D AUTOUPD^DGENA2(DA)
  S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET
-C2S S X="" G:DG(DQ)=X C2F1 K DB
+C2S S X="" Q:DG(DQ)=X  K DB
  S X=DG(DQ),DIC=DIE
  X "S DFN=DA D EN^DGMTR K DGREQF"
@@ -125,5 +121,5 @@
  D AUTOUPD^DGENA2(DA)
  I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C2F1 Q
+ Q
 X2 Q
 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVICE",DIFLD=.323
@@ -141,8 +137,6 @@
  S X=DE(3),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
- S X=DE(3),DIC=DIE
- D EVENT^IVMPLOG(DA)
  S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET
-C3S S X="" G:DG(DQ)=X C3F1 K DB
+C3S S X="" Q:DG(DQ)=X  K DB
  S X=DG(DQ),DIC=DIE
  S ^DPT("APOS",$E(X,1,30),DA)=""
@@ -151,8 +145,6 @@
  S X=DG(DQ),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA)
- S X=DG(DQ),DIC=DIE
- D EVENT^IVMPLOG(DA)
  I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C3F1 Q
+ Q
 X3 S DFN=DA D POS^DGLOCK1
  Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA01.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA01.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA01.m	(revision 623)
@@ -1,75 +1,73 @@
-DGRUGA01	;ALB/GRR - HL7 ADT A01 MESSAGE BUILDER ; 11/27/07 1:43pm
-	;;5.3;Registration;**190,303,762**;Aug 13, 1993;Build 3
-	;
-	;This routine will build a ADT A01 (Admit) HL7 message for an inpatient.
-	;
-EN(DFN,DGMIEN,DGARRAY)	;Entry point of routine
-	;DFN - Patient Internal Entry Number
-	;DGMIEN - Patient Movement Internal Entry Number
-	;DGARRAY - Name of output array by reference where built message will be contained.
-	;
-	;The HL7 variables must be initialized before calling this routine!
-	;HL("FS"),HL("ECH"),HLFS,HLECH, and HLQ are used by segment builders called by this routine
-	;
-	N DGPV1,DGHOLD,DGCNT,DGMDT,DGCDT,DGOADT,DGZEL,DGICD,DGICDCNT,DGIN,DGIN1,DGRB,DGW,DGINCNT S DGCNT=0
-	Q:DGARRAY=""  ;Required output variable name was not passed
-	K @DGARRAY ;Kill output array to insure erroneous data does not exist
-	Q:DGMIEN=""
-	S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
-	D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
-	S DGCNT=DGCNT+1 ;Increment node counter by one for first segment
-	S @DGARRAY@(DGCNT)=$$EVN^VAFHLEVN("A01","05",DGMDT) ;Create Event segment and store in output array
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFCPID(DFN,",2,5,7,8,10,11,13,16,17,19,23,29",1) ;Create PID segment using segment sequence numbers passed and store in output array
-	S DGHOLD=$$EN^VAFHLNK1(DFN,DGMIEN,",2,3,4,5,") ;Create the NK1 segment using the segment sequence numbers passed, and store in output array
-	I DGHOLD]"" S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGHOLD
-	S DGCNT=DGCNT+1 ;Increment node counter by one to store next segment
-	S DGPV1=$$IN^VAFHLPV1(DFN,DGMDT,",2,3,6,7,10,17,44,",$G(DGMIEN),"","") ;Create the PV1 segment based on sequence numbers passed, and store in output array
-	S DGOADT=$$CKADMIT^DGRUUTL1(DFN) ;Check if integrated site and get original admit date
-	;Check if doing data seed of RAI/MDS machine
-	I $G(DGSEED)=1 D
-	.N VAIP,DGPCPNM,DGPCPPTR,DGWPTR,DGRBPTR,DGWTRAN,DGRBTRAN
-	.D IN5^VADPT
-	.;Put current Primary Care Physician into PV1 segment
-	.S DGPCPPTR=+$G(VAIP(7))
-	.S DGPCPNM=$$HLNAME^HLFNC($P($G(VAIP(7)),"^",2))
-	.S:DGPCPNM="" DGPCPNM=HL("Q")
-	.S $P(DGPV1,HL("FS"),8)=DGPCPPTR_$E(HL("ECH"))_DGPCPNM
-	.K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
-	.;Get current ward & room/bed
-	.S DGW=$$GET1^DIQ(2,DFN,.1,"I")
-	.S DGRB=$$GET1^DIQ(2,DFN,.101,"I")
-	.;Convert ward & room/bed to pointers
-	.S DGWPTR=$$FIND1^DIC(42,,"XQ",DGW)
-	.S DGRBPTR=$$FIND1^DIC(405.4,,"XQ",DGRB)
-	.;Translate ward & room/bed
-	.S DGWTRAN=$$WARDTRAN^DGRUUTL1(DGWPTR,DGW)
-	.S DGRBTRAN=$$RBTRAN^DGRUUTL1(DGRBPTR,DGRB)
-	.;Put translated ward & room/bed into PV1 segment
-	.S $P(DGPV1,HL("FS"),4)=DGWTRAN_$E(HL("ECH"))_$P(DGRBTRAN,"-")_$E(HL("ECH"))_$P(DGRBTRAN,"-",2)
-	I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT) S $P(@DGARRAY@(1),HL("FS"),7)=$$HLDATE^HLFNC(DGOADT)
-	S DGPV1=$$DOCID^DGRUUTL(DGPV1)
-	K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
-	;TRANSLATE WARD AND ROOM-BED NAMES IF NEEDED (ALREADY DONE IF SEEDING)
-	S:'$G(DGSEED) DGPV1=$$LOCTRAN^DGRUUTL1(DGPV1)
-	S @DGARRAY@(DGCNT)=DGPV1
-	S DGCNT=DGCNT+1 ;Increment node counter to store next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLPV2(DFN,DGMIEN,",3,") ;Create PV2 segment
-	D IN^VAFHLDG1(DFN,DGMIEN,",2,3,5,","DGICD",DGMDT) ;Create the DG1 segment(s) and store in a temporary array
-	I $O(DGICD(0))>0 D  ;DG1 segment were built
-	.S DGICDCNT=0 F  S DGICDCNT=$O(DGICD(DGICDCNT)) Q:DGICDCNT=""  S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGICD(DGICDCNT,0) ;Loop through temporary array and store DG1 segment(s) in output array
-	S DGIN1=$$IN1^DGRUUTL1(DFN)
-	S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGIN1
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLIN2(DFN,DGMIEN,",2,3,6,8,") ;Create and store IN2 segment in output array
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S DGZEL=$$EN^VAFHLZEL(DFN,",1,8,",1) ;Create ZEL segment (only primary eligibility - param 3 = 1)
-	I $P(DGZEL,HL("FS"),9)'=0&($P(DGZEL,HL("FS"),9)'=1) S $P(DGZEL,HL("FS"),9)=1 ;stuff patient as veteran
-	S @DGARRAY@(DGCNT)=DGZEL
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLZEM(DFN,",1,5,",1,1) ;Create ZEM segment for Patient (param 3 = 1)
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLZEN(DFN,",1,9,",1,"",HL("FS")) ;Create ZEN segment and add to message array
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLZMH(DFN,DGMIEN,",4,") ;Create the ZMH segment and store in the output array
-	Q
+DGRUGA01 ;ALB/GRR - HL7 ADT A01 MESSAGE BUILDER ;06/08/99
+ ;;5.3;Registration;**190,303**;Aug 13, 1993
+ ;
+ ;This routine will build a ADT A01 (Admit) HL7 message for an inpatient.
+ ;
+EN(DFN,DGMIEN,DGARRAY) ;Entry point of routine
+ ;DFN - Patient Internal Entry Number
+ ;DGMIEN - Patient Movement Internal Entry Number
+ ;DGARRAY - Name of output array by reference where built message will be contained.
+ ;
+ ;The HL7 variables must be initialized before calling this routine!
+ ;HL("FS"),HL("ECH"),HLFS,HLECH, and HLQ are used by segment builders called by this routine
+ ;
+ N DGPV1,DGHOLD,DGCNT,DGMDT,DGCDT,DGOADT,DGZEL,DGICD,DGICDCNT,DGIN,DGIN1,DGRB,DGW,DGINCNT S DGCNT=0
+ Q:DGARRAY=""  ;Required output variable name was not passed
+ K @DGARRAY ;Kill output array to insure erroneous data does not exist
+ Q:DGMIEN=""
+ S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
+ D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
+ S DGCNT=DGCNT+1 ;Increment node counter by one for first segment
+ S @DGARRAY@(DGCNT)=$$EVN^VAFHLEVN("A01","05",DGMDT) ;Create Event segment and store in output array
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFCPID(DFN,",2,5,7,8,10,11,13,16,17,19,23,29",1) ;Create PID segment using segment sequence numbers passed and store in output array
+ S DGHOLD=$$EN^VAFHLNK1(DFN,DGMIEN,",2,3,4,5,") ;Create the NK1 segment using the segment sequence numbers passed, and store in output array
+ I DGHOLD]"" S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGHOLD
+ S DGCNT=DGCNT+1 ;Increment node counter by one to store next segment
+ S DGPV1=$$IN^VAFHLPV1(DFN,DGMDT,",2,3,6,7,10,17,44,",$G(DGMIEN),"","") ;Create the PV1 segment based on sequence numbers passed, and store in output array
+ S DGOADT=$$CKADMIT^DGRUUTL1(DFN) ;Check if integrated site and get original admit date
+ ;Check if doing data seed of RAI/MDS machine
+ I $G(DGSEED)=1 D
+ .N VAIP,DGPCPNM,DGPCPPTR,DGWPTR,DGRBPTR,DGWTRAN,DGRBTRAN
+ .D IN5^VADPT
+ .;Put current Primary Care Physician into PV1 segment
+ .S DGPCPPTR=+$G(VAIP(7))
+ .S DGPCPNM=$$HLNAME^HLFNC($P($G(VAIP(7)),"^",2))
+ .S:DGPCPNM="" DGPCPNM=HL("Q")
+ .S $P(DGPV1,HL("FS"),8)=DGPCPPTR_$E(HL("ECH"))_DGPCPNM
+ .;Get current ward & room/bed
+ .S DGW=$$GET1^DIQ(2,DFN,.1,"I")
+ .S DGRB=$$GET1^DIQ(2,DFN,.101,"I")
+ .;Convert ward & room/bed to pointers
+ .S DGWPTR=$$FIND1^DIC(42,,"XQ",DGW)
+ .S DGRBPTR=$$FIND1^DIC(405.4,,"XQ",DGRB)
+ .;Translate ward & room/bed
+ .S DGWTRAN=$$WARDTRAN^DGRUUTL1(DGWPTR,DGW)
+ .S DGRBTRAN=$$RBTRAN^DGRUUTL1(DGRBPTR,DGRB)
+ .;Put translated ward & room/bed into PV1 segment
+ .S $P(DGPV1,HL("FS"),4)=DGWTRAN_$E(HL("ECH"))_$P(DGRBTRAN,"-")_$E(HL("ECH"))_$P(DGRBTRAN,"-",2)
+ I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT) S $P(@DGARRAY@(1),HL("FS"),7)=$$HLDATE^HLFNC(DGOADT)
+ S DGPV1=$$DOCID^DGRUUTL(DGPV1)
+ ;TRANSLATE WARD AND ROOM-BED NAMES IF NEEDED (ALREADY DONE IF SEEDING)
+ S:'$G(DGSEED) DGPV1=$$LOCTRAN^DGRUUTL1(DGPV1)
+ S @DGARRAY@(DGCNT)=DGPV1
+ S DGCNT=DGCNT+1 ;Increment node counter to store next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLPV2(DFN,DGMIEN,",3,") ;Create PV2 segment
+ D IN^VAFHLDG1(DFN,DGMIEN,",2,3,5,","DGICD",DGMDT) ;Create the DG1 segment(s) and store in a temporary array
+ I $O(DGICD(0))>0 D  ;DG1 segment were built
+ .S DGICDCNT=0 F  S DGICDCNT=$O(DGICD(DGICDCNT)) Q:DGICDCNT=""  S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGICD(DGICDCNT,0) ;Loop through temporary array and store DG1 segment(s) in output array
+ S DGIN1=$$IN1^DGRUUTL1(DFN)
+ S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGIN1
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLIN2(DFN,DGMIEN,",2,3,6,8,") ;Create and store IN2 segment in output array
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S DGZEL=$$EN^VAFHLZEL(DFN,",1,8,",1) ;Create ZEL segment (only primary eligibility - param 3 = 1)
+ I $P(DGZEL,HL("FS"),9)'=0&($P(DGZEL,HL("FS"),9)'=1) S $P(DGZEL,HL("FS"),9)=1 ;stuff patient as veteran
+ S @DGARRAY@(DGCNT)=DGZEL
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLZEM(DFN,",1,5,",1,1) ;Create ZEM segment for Patient (param 3 = 1)
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLZEN(DFN,",1,9,",1,"",HL("FS")) ;Create ZEN segment and add to message array
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLZMH(DFN,DGMIEN,",4,") ;Create the ZMH segment and store in the output array
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA08.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA08.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA08.m	(revision 623)
@@ -1,61 +1,60 @@
-DGRUGA08	;ALB/GRR - HL7 ADT A08 MESSAGE BUILDER ; 10/11/07 9:24am
-	;;5.3;Registration;**190,312,328,721,762**;Aug 13, 1993;Build 3
-	;
-	;This routine will build a ADT A08 (Patient Update) HL7 message for an inpatient.
-	;
-EN(DFN,DGMIEN,DGARRAY,DGDC,DGSSNC)	;Entry point of routine
-	;DFN - Patient Internal Entry Number
-	;DGMIEN - Patient Movement Internal Entry Number
-	;DGARRAY - Name of output array by reference where built message will be contained.
-	;DGDC - date type~prior date (date type is A, T, or D) (Required for date change only) [Optional]
-	;DGSSNC - Prior SSN (Required for SSN Change only) [Optional]
-	;
-	;The HL7 variables must be initialized before calling this routine!
-	;HL("FS"),HL("ECH"),HLFS,HLECH, and HLQ are used by segment builders called by this routine
-	;
-	N DGPV1,DGHOLD,DGCNT,DGMDT,DGCDT,DGOADT,DGIN1,DGLMT,DGZEL,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
-	Q:DGARRAY=""  ;Required output variable name was not passed
-	K @DGARRAY ;Kill output array to insure erroneous data does not exist
-	I DGMIEN="" N VAIP D NOW^%DTC S VAIP("D")=% D IN5^VADPT S DGMIEN=$G(VAIP(1)) K VAIP Q:DGMIEN=""  ;changed p-328
-	D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
-	S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
-	S DGCNT=DGCNT+1 ;Increment node counter by one for first segment
-	S @DGARRAY@(DGCNT)=$$EVN^VAFHLEVN("A08","05",DGMDT) ;Create Event segment and store in output array
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFCPID(DFN,",2,5,7,8,10,11,13,16,17,19,23,29",1) ;Create PID segment using segment sequence numbers passed and store in output array
-	S DGHOLD=$$EN^VAFHLNK1(DFN,DGMIEN,",2,3,4,5,") ;Create the NK1 segment using the segment sequence numbers passed, and store in output array
-	I DGHOLD]"" S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGHOLD
-	S DGCNT=DGCNT+1 ;Increment node counter by one to store next segment
-	S DGPV1=$$IN^VAFHLPV1(DFN,DGMDT,",2,3,6,7,10,17,44,45,",DGMIEN,"","") ;Create the PV1 segment based on sequence numbers passed
-	S DGOADT=$$CKADMIT^DGRUUTL1(DFN) ;check if integrated site get original admit date/time
-	I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT)
-	S DGPV1=$$DOCID^DGRUUTL(DGPV1)
-	I $G(DGLMT)=1,$E($G(DGDC))="D" S $P(DGPV1,HL("FS"),4)=$P(DGPV1,HL("FS"),7) ;This is a change to a prior HL7, move prior location to current
-	N VAIP D IN5^VADPT S $P(DGPV1,HL("FS"),11)=$$GET1^DIQ(45.7,+VAIP(8),1,"I") K VAIP ; p-721
-	K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
-	S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1)
-	S DGCNT=DGCNT+1 ;Increment node counter to store next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLPV2(DFN,DGMIEN,",3,") ;Create PV2 segment
-	D IN^VAFHLDG1(DFN,DGMIEN,",2,3,5,","DGICD") ;Create the DG1 segment(s) and store in a temporary array
-	I $O(DGICD(0))>0 D  ;DG1 segment were built
-	.S DGICDCNT=0 F  S DGICDCNT=$O(DGICD(DGICDCNT)) Q:DGICDCNT=""  S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGICD(DGICDCNT,0) ;Loop through temporary array and store DG1 segment(s) in output array
-	S DGIN1=$$IN1^DGRUUTL1(DFN)
-	S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGIN1
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLIN2(DFN,DGMIEN,",2,3,6,8,") ;Create and store IN2 segment in output array
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S DGZEL=$$EN^VAFHLZEL(DFN,",1,8,",1) ;Create ZEL segment (only primary eligibility - param 3 = 1)
-	I $P(DGZEL,HL("FS"),9)'=0&($P(DGZEL,HL("FS"),9)'=1) S $P(DGZEL,HL("FS"),9)=1 ;stuff patient as veteran
-	S @DGARRAY@(DGCNT)=DGZEL
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLZEM(DFN,",1,5,",1,1) ;Create ZEM segment for Patient (param 3 = 1)
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLZEN(DFN,",1,9,",1,"",HL("FS")) ;Create ZEN segment and add to message array
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFHLZMH(DFN,DGMIEN,",4,") ;Create the ZMH segment and store in the output array
-	S DGDC=$G(DGDC),DGSSNC=$G(DGSSNC)
-	I DGDC]""!(DGSSNC]"") D  ;date or ssn change
-	.I DGDC]""&'("ADT"[$E(DGDC)) Q
-	.S DGCNT=DGCNT+1
-	.S @DGARRAY@(DGCNT)=$$EN^DGRUGZDC(DFN,DGDC,DGSSNC,DGMDT)
-	Q
+DGRUGA08 ;ALB/GRR - HL7 ADT A08 MESSAGE BUILDER ; 21 Sep 2006  8:24 AM
+ ;;5.3;Registration;**190,312,328,721**;Aug 13, 1993;Build 3
+ ;
+ ;This routine will build a ADT A08 (Patient Update) HL7 message for an inpatient.
+ ;
+EN(DFN,DGMIEN,DGARRAY,DGDC,DGSSNC) ;Entry point of routine
+ ;DFN - Patient Internal Entry Number
+ ;DGMIEN - Patient Movement Internal Entry Number
+ ;DGARRAY - Name of output array by reference where built message will be contained.
+ ;DGDC - date type~prior date (date type is A, T, or D) (Required for date change only) [Optional]
+ ;DGSSNC - Prior SSN (Required for SSN Change only) [Optional]
+ ;
+ ;The HL7 variables must be initialized before calling this routine!
+ ;HL("FS"),HL("ECH"),HLFS,HLECH, and HLQ are used by segment builders called by this routine
+ ;
+ N DGPV1,DGHOLD,DGCNT,DGMDT,DGCDT,DGOADT,DGIN1,DGLMT,DGZEL,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
+ Q:DGARRAY=""  ;Required output variable name was not passed
+ K @DGARRAY ;Kill output array to insure erronuous data does not exist
+ I DGMIEN="" N VAIP D NOW^%DTC S VAIP("D")=% D IN5^VADPT S DGMIEN=$G(VAIP(1)) K VAIP Q:DGMIEN=""  ;changed p-328
+ D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
+ S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
+ S DGCNT=DGCNT+1 ;Increment node counter by one for first segment
+ S @DGARRAY@(DGCNT)=$$EVN^VAFHLEVN("A08","05",DGMDT) ;Create Event segment and store in output array
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFCPID(DFN,",2,5,7,8,10,11,13,16,17,19,23,29",1) ;Create PID segment using segment sequence numbers passed and store in output array
+ S DGHOLD=$$EN^VAFHLNK1(DFN,DGMIEN,",2,3,4,5,") ;Create the NK1 segment using the segment sequence numbers passed, and store in output array
+ I DGHOLD]"" S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGHOLD
+ S DGCNT=DGCNT+1 ;Increment node counter by one to store next segment
+ S DGPV1=$$IN^VAFHLPV1(DFN,DGMDT,",2,3,6,7,10,17,44,45,",DGMIEN,"","") ;Create the PV1 segment based on sequence numbers passed
+ S DGOADT=$$CKADMIT^DGRUUTL1(DFN) ;check if integrated site get original admit date/time
+ I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT)
+ S DGPV1=$$DOCID^DGRUUTL(DGPV1)
+ I $G(DGLMT)=1,$E($G(DGDC))="D" S $P(DGPV1,HL("FS"),4)=$P(DGPV1,HL("FS"),7) ;This is a change to a prior HL7, move prior location to current
+ N VAIP D IN5^VADPT S $P(DGPV1,HL("FS"),11)=$$GET1^DIQ(45.7,+VAIP(8),1,"I") K VAIP ; p-721
+ S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1)
+ S DGCNT=DGCNT+1 ;Increment node counter to store next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLPV2(DFN,DGMIEN,",3,") ;Create PV2 segment
+ D IN^VAFHLDG1(DFN,DGMIEN,",2,3,5,","DGICD") ;Create the DG1 segment(s) and store in a temporary array
+ I $O(DGICD(0))>0 D  ;DG1 segment were built
+ .S DGICDCNT=0 F  S DGICDCNT=$O(DGICD(DGICDCNT)) Q:DGICDCNT=""  S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGICD(DGICDCNT,0) ;Loop through temporary array and store DG1 segment(s) in output array
+ S DGIN1=$$IN1^DGRUUTL1(DFN)
+ S DGCNT=DGCNT+1,@DGARRAY@(DGCNT)=DGIN1
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLIN2(DFN,DGMIEN,",2,3,6,8,") ;Create and store IN2 segment in output array
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S DGZEL=$$EN^VAFHLZEL(DFN,",1,8,",1) ;Create ZEL segment (only primary eligibility - param 3 = 1)
+ I $P(DGZEL,HL("FS"),9)'=0&($P(DGZEL,HL("FS"),9)'=1) S $P(DGZEL,HL("FS"),9)=1 ;stuff patient as veteran
+ S @DGARRAY@(DGCNT)=DGZEL
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLZEM(DFN,",1,5,",1,1) ;Create ZEM segment for Patient (param 3 = 1)
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLZEN(DFN,",1,9,",1,"",HL("FS")) ;Create ZEN segment and add to message array
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFHLZMH(DFN,DGMIEN,",4,") ;Create the ZMH segment and store in the output array
+ S DGDC=$G(DGDC),DGSSNC=$G(DGSSNC)
+ I DGDC]""!(DGSSNC]"") D  ;date or ssn change
+ .I DGDC]""&'("ADT"[$E(DGDC)) Q
+ .S DGCNT=DGCNT+1
+ .S @DGARRAY@(DGCNT)=$$EN^DGRUGZDC(DFN,DGDC,DGSSNC,DGMDT)
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA22.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA22.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA22.m	(revision 623)
@@ -1,34 +1,33 @@
-DGRUGA22	;ALB/GRR - HL7 ADT A22 MESSAGE BUILDER ; 11/7/07 3:45pm
-	;;5.3;Registration;**190,762**;Aug 13, 1993;Build 3
-	;
-	;This routine will build a ADT A22 (From Leave of Absence) HL7 message for an inpatient.
-	;
-EN(DFN,DGMIEN,DGARRAY)	;Entry point of routine
-	;DFN - Patient Internal Entry Number
-	;DGMIEN - Patient Movement Internal Entry Number
-	;DGARRAY - Name of output array by reference where built message will be contained.
-	;
-	;The HL7 variables must be initialized before calling this routine!
-	;HL("FS"),HL("ECH"),HLFS,HLECH, and HLQ are used by segment builders called by this routine
-	;
-	N DGPV1,DGCNT,DGMDT,DGCDT,DGOADT,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
-	Q:DGARRAY=""  ;Required output variable name was not passed
-	K @DGARRAY ;Kill output array to insure erroneous data does not exist
-	Q:DGMIEN=""
-	S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
-	D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
-	S DGCNT=DGCNT+1 ;Increment node counter by one for first segment
-	S @DGARRAY@(DGCNT)=$$EVN^VAFHLEVN("A22","05",DGMDT) ;Create Event segment and store in output array
-	S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
-	S @DGARRAY@(DGCNT)=$$EN^VAFCPID(DFN,",2,5,7,8,10,11,13,16,17,19,23,29",1) ;Create PID segment using segment sequence numbers passed and store in output array
-	S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I") ;Retrieve Movement Date/Time
-	S DGCNT=DGCNT+1 ;Increment node counter by one to store next segment
-	S DGPV1=$$IN^VAFHLPV1(DFN,DGMDT,",2,3,6,7,10,17,44,",$G(DGMIEN),"","") ;Create the PV1 segment based on sequence numbers passed
-	S DGOADT=$$CKADMIT^DGRUUTL1(DFN) ;check if integrated site get original admit date/time
-	I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT)
-	S DGPV1=$$DOCID^DGRUUTL(DGPV1)
-	N VAIP,DGW,DGRM D IN5^VADPT S DGW=$P(VAIP(5),"^",2),DGRM=$P(VAIP(6),"^",2),$P(DGPV1,HL("FS"),4)=DGW_$E(HLECH)_DGRM K VAIP ; P-762
-	S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1) ;Translate Ward and Room-Bed name, store into array
-	S DGMTYP=$$GET1^DIQ(405,DGMIEN,.18,"I") ;Get Movement Type
-	I DGMTYP=14!(DGMTYP=41) S $P(@DGARRAY@(DGCNT),HL("FS"),41)="H" ;If From ASIH flag bed status field as 'H'
-	Q
+DGRUGA22 ;ALB/GRR - HL7 ADT A22 MESSAGE BUILDER ;8/5/99  15:36
+ ;;5.3;Registration;**190**;Aug 13, 1993
+ ;
+ ;This routine will build a ADT A22 (From Leave of Absence) HL7 message for an inpatient.
+ ;
+EN(DFN,DGMIEN,DGARRAY) ;Entry point of routine
+ ;DFN - Patient Internal Entry Number
+ ;DGMIEN - Patient Movement Internal Entry Number
+ ;DGARRAY - Name of output array by reference where built message will be contained.
+ ;
+ ;The HL7 variables must be initialized before calling this routine!
+ ;HL("FS"),HL("ECH"),HLFS,HLECH, and HLQ are used by segment builders called by this routine
+ ;
+ N DGPV1,DGCNT,DGMDT,DGCDT,DGOADT,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
+ Q:DGARRAY=""  ;Required output variable name was not passed
+ K @DGARRAY ;Kill output array to insure erronuous data does not exist
+ Q:DGMIEN=""
+ S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
+ D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
+ S DGCNT=DGCNT+1 ;Increment node counter by one for first segment
+ S @DGARRAY@(DGCNT)=$$EVN^VAFHLEVN("A22","05",DGMDT) ;Create Event segment and store in output array
+ S DGCNT=DGCNT+1 ;Increment node counter by one for next segment
+ S @DGARRAY@(DGCNT)=$$EN^VAFCPID(DFN,",2,5,7,8,10,11,13,16,17,19,23,29",1) ;Create PID segment using segment sequence numbers passed and store in output array
+ S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I") ;Retrieve Movement Date/Time
+ S DGCNT=DGCNT+1 ;Increment node counter by one to store next segment
+ S DGPV1=$$IN^VAFHLPV1(DFN,DGMDT,",2,3,6,7,10,17,44,",$G(DGMIEN),"","") ;Create the PV1 segment based on sequence numbers passed
+ S DGOADT=$$CKADMIT^DGRUUTL1(DFN) ;check if integrated site get original admit date/time
+ I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT)
+ S DGPV1=$$DOCID^DGRUUTL(DGPV1)
+ S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1) ;Translate Ward and Room-Bed name, store into array
+ S DGMTYP=$$GET1^DIQ(405,DGMIEN,.18,"I") ;Get Movement Type
+ I DGMTYP=14!(DGMTYP=41) S $P(@DGARRAY@(DGCNT),HL("FS"),41)="H" ;If From ASIH flag bed status field as 'H'
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGBJ.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGBJ.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGBJ.m	(revision 623)
@@ -1,112 +1,111 @@
-DGRUGBJ	; ALB/SCK - RAI/MDS COTS ADT Background job ; 11/7/07 3:49pm
-	;;5.3;Registration;**190,312,357,762**;Aug 13, 1993;Build 3
-	;
-EN	; Main Entry point for patient demographic update to COTS system
-	;
-	L +^XTMP("ADT/HL7 MDS COTS UPDATE"):3 E  Q
-	;
-	; Check for HL7 send parameter
-	Q:'$P($$SEND^VAFHUTL(),"^",2)
-	;
-	; Look for patient demographic changes monitored by the COTS system
-	N PVTPTR,DGNODE,DFN,DGDATE,DGARRAY,DGUSR,DGRSLT
-	;
-	S DGARRAY="^TMP(""DGRAI"",""EVNTINFO"","_$J_")"
-	K @DGARRAY
-	;
-	; Begin looking for entries needing transmission with a type of "COTS UPDATE", Code 6.
-	S PVTPTR=0
-	F  S PVTPTR=+$O(^VAT(391.71,"AXMIT",6,PVTPTR)) Q:('PVTPTR)  D
-	. ; If no entry for xref (out of sync) delete the xref and quit
-	. I ('$D(^VAT(391.71,PVTPTR))) K ^VAT(391.71,"AXMIT",6,PVTPTR) Q
-	. ; Get event date and pointer to patient for entry
-	. S DGNODE=$G(^VAT(391.71,PVTPTR,0))
-	. S DFN=+$P(DGNODE,"^",3)
-	. S EVNTDT=+DGNODE
-	. ; Check for patient, if not valid, then mark as transmitted and quit
-	. I ('$D(^DPT(DFN,0))) D XMITFLAG^VAFCDD01(PVTPTR,"",1) Q
-	. N VAIN D INP^VADPT ; p-762
-	. I '$$CHKWARD^DGRUUTL(+VAIN(4)) D XMITFLAG^VAFCDD01(PVTPTR,"",1) K VAIN Q  ; P-762
-	. K @DGARRAY
-	. S @DGARRAY@("PIVOT")=PVTPTR
-	. S @DGARRAY@("REASON",1)=""
-	. I (+$G(^DPT(DFN,.35))) S @DGARRAY@("REASON",1)=99
-	. ;
-	. S @DGARRAY@("USER")=$$GET1^DIQ(200,+$P(DGNODE,"^",9),.01)
-	. ;
-	. S @DGARRAY@("EVENT-NUM")=$P(DGNODE,"^",2)
-	. S @DGARRAY@("VAR-PTR")=$P(DGNODE,"^",5)
-	. ;
-	. S DGRSLT=$$BLDA08(DFN,EVNTDT,DGARRAY)
-	. I (DGRSLT<0) D ERRBUL(DGARRAY,DGRSLT) ;deleted Q p-357
-	. ;
-	. ; Mark entry in pivot file as transmitted
-	. D XMITFLAG^VAFCDD01(PVTPTR,"",1)
-	;
-	L -^XTMP("ADT/HL7 MDS COTS UPDATE")
-	Q
-	;
-BLDA08(DFN,EVNTDT,EVNTINFO,DGDC,DGOSSN)	;
-	;
-	N RESULT,DGTMP,GLOREF
-	;
-	S DFN=+$G(DFN)
-	I ('$D(^DPT(DFN,0))) S RESULT="-1^Could not find entry in PATIENT file" G BLDQ
-	;
-	S DGDC=$G(DGDC)
-	S DGOSSN=$G(DGOSSN)
-	S EVNTDT=$G(EVNTDT)
-	S:('EVNTDT) EVNTDT=$$NOW^XLFDT
-	;
-	S GLOREF="^TMP(""HLS"","_$J_")"
-	K @GLOREF
-	;
-	S @EVNTINFO@("DFN")=DFN
-	S @EVNTINFO@("EVENT")="A08"
-	S @EVNTINFO@("DATE")=EVNTDT
-	;
-	N HLEID,HL,HLFS,HLECH,HLQ,NDX
-	;
-	K HL
-	D INIT^HLFNC2("DGRU-PATIENT-A08-SERVER",.HL)
-	;
-	I ($O(HL(""))']"") S RESULT="-1^Server Protocol not found" G BLDQ
-	;
-	; Build segment array
-	D EN^DGRUGA08(DFN,"","DGTMP",DGDC,DGOSSN)
-	I '$O(DGTMP(0)) S RESULT="-1^Unable to build segment list to transmit" G BLDQ
-	;Check segment list for errors
-	S NDX=0
-	F  S NDX=$O(DGTMP(NDX)) Q:'NDX  D  G:(+$G(RESULT)<0) BLDQ
-	. I +DGTMP(NDX)<0 S RESULT="-1^An error occurred in one of the segments"
-	;
-	M @GLOREF=DGTMP
-	S RESULT=$$SENDMSG(GLOREF)
-	I +$P(RESULT,"^",2)>0 S RESULT="-1^"_$P(RESULT,"^",2,3)
-BLDQ	Q $G(RESULT)
-	;
-SENDMSG(GLOREF)	; Transmit the HL7 message
-	N HLA,HLRST
-	M HLA("HLS")=@GLOREF
-	I $D(HLA("HLS")) D
-	. D GENERATE^HLMA("DGRU-PATIENT-A08-SERVER","LM",1,.HLRST,"")
-	K HLA,HERR
-	Q (HLRST)
-	;
-ERRBUL(EVNTINFO,RESULT)	; Generate bulletin if an error occurred while building the HL7 message.
-	;
-	N XMY,XMDUZ,XMDT,XMZ,XMB,XMCHAN,XMSUB
-	;
-	S XMCHAN=1
-	S XMSUB="RAI/MDS HL7 BUILD ERROR"
-	S (XMDUZ,XMDUZ)="RAI/MDS APPLICATION"
-	;
-	S XMB="DGRU RAI ERROR"
-	S XMB(1)=$$GET1^DIQ(2,@EVNTINFO@("DFN"),.01)
-	S XMB(2)=@EVNTINFO@("EVENT")
-	S XMB(3)=">>> "_$P(RESULT,"^",2)
-	S XMB(4)=@EVNTINFO@("USER")
-	S XMB(5)=$$FMTE^XLFDT(@EVNTINFO@("DATE"))
-	S XMDT=DT
-	D ^XMB
-	Q
+DGRUGBJ ; ALB/SCK - RAI/MDS COTS ADT Background job ; 8-10-99
+ ;;5.3;Registration;**190,312,357**;Aug 13, 1993
+ ;
+EN ; Main Entry point for patient demographic update to COTS system
+ ;
+ L +^XTMP("ADT/HL7 MDS COTS UPDATE"):3 E  Q
+ ;
+ ; Check for HL7 send parameter
+ Q:'$P($$SEND^VAFHUTL(),"^",2)
+ ;
+ ; Look for patient demographic changes monitored by the COTS system
+ N PVTPTR,DGNODE,DFN,DGDATE,DGARRAY,DGUSR,DGRSLT
+ ;
+ S DGARRAY="^TMP(""DGRAI"",""EVNTINFO"","_$J_")"
+ K @DGARRAY
+ ;
+ ; Begin looking for entries needing transmission with a type of "COTS UPDATE", Code 6.
+ S PVTPTR=0
+ F  S PVTPTR=+$O(^VAT(391.71,"AXMIT",6,PVTPTR)) Q:('PVTPTR)  D
+ . ; If no entry for xref (out of sync) delete the xref and quit
+ . I ('$D(^VAT(391.71,PVTPTR))) K ^VAT(391.71,"AXMIT",6,PVTPTR) Q
+ . ; Get event date and pointer to patient for entry
+ . S DGNODE=$G(^VAT(391.71,PVTPTR,0))
+ . S DFN=+$P(DGNODE,"^",3)
+ . S EVNTDT=+DGNODE
+ . ; Check for patient, if not valid, then mark as transmitted and quit
+ . I ('$D(^DPT(DFN,0))) D XMITFLAG^VAFCDD01(PVTPTR,"",1) Q
+ . ;
+ . K @DGARRAY
+ . S @DGARRAY@("PIVOT")=PVTPTR
+ . S @DGARRAY@("REASON",1)=""
+ . I (+$G(^DPT(DFN,.35))) S @DGARRAY@("REASON",1)=99
+ . ;
+ . S @DGARRAY@("USER")=$$GET1^DIQ(200,+$P(DGNODE,"^",9),.01)
+ . ;
+ . S @DGARRAY@("EVENT-NUM")=$P(DGNODE,"^",2)
+ . S @DGARRAY@("VAR-PTR")=$P(DGNODE,"^",5)
+ . ;
+ . S DGRSLT=$$BLDA08(DFN,EVNTDT,DGARRAY)
+ . I (DGRSLT<0) D ERRBUL(DGARRAY,DGRSLT) ;deleted Q p-357
+ . ;
+ . ; Mark entry in pivot file as transmitted
+ . D XMITFLAG^VAFCDD01(PVTPTR,"",1)
+ ;
+ L -^XTMP("ADT/HL7 MDS COTS UPDATE")
+ Q
+ ;
+BLDA08(DFN,EVNTDT,EVNTINFO,DGDC,DGOSSN) ;
+ ;
+ N RESULT,DGTMP,GLOREF
+ ;
+ S DFN=+$G(DFN)
+ I ('$D(^DPT(DFN,0))) S RESULT="-1^Could not find entry in PATIENT file" G BLDQ
+ ;
+ S DGDC=$G(DGDC)
+ S DGOSSN=$G(DGOSSN)
+ S EVNTDT=$G(EVNTDT)
+ S:('EVNTDT) EVNTDT=$$NOW^XLFDT
+ ;
+ S GLOREF="^TMP(""HLS"","_$J_")"
+ K @GLOREF
+ ;
+ S @EVNTINFO@("DFN")=DFN
+ S @EVNTINFO@("EVENT")="A08"
+ S @EVNTINFO@("DATE")=EVNTDT
+ ;
+ N HLEID,HL,HLFS,HLECH,HLQ,NDX
+ ;
+ K HL
+ D INIT^HLFNC2("DGRU-PATIENT-A08-SERVER",.HL)
+ ;
+ I ($O(HL(""))']"") S RESULT="-1^Server Protocol not found" G BLDQ
+ ;
+ ; Build segment array
+ D EN^DGRUGA08(DFN,"","DGTMP",DGDC,DGOSSN)
+ I '$O(DGTMP(0)) S RESULT="-1^Unable to build segment list to transmit" G BLDQ
+ ;Check segment list for errors
+ S NDX=0
+ F  S NDX=$O(DGTMP(NDX)) Q:'NDX  D  G:(+$G(RESULT)<0) BLDQ
+ . I +DGTMP(NDX)<0 S RESULT="-1^An error occurred in one of the segments"
+ ;
+ M @GLOREF=DGTMP
+ S RESULT=$$SENDMSG(GLOREF)
+ I +$P(RESULT,"^",2)>0 S RESULT="-1^"_$P(RESULT,"^",2,3)
+BLDQ Q $G(RESULT)
+ ;
+SENDMSG(GLOREF) ; Transmit the HL7 message
+ N HLA,HLRST
+ M HLA("HLS")=@GLOREF
+ I $D(HLA("HLS")) D
+ . D GENERATE^HLMA("DGRU-PATIENT-A08-SERVER","LM",1,.HLRST,"")
+ K HLA,HERR
+ Q (HLRST)
+ ;
+ERRBUL(EVNTINFO,RESULT) ; Generate bulliten if an error occurred while building the HL7 message.
+ ;
+ N XMY,XMDUZ,XMDT,XMZ,XMB,XMCHAN,XMSUB
+ ;
+ S XMCHAN=1
+ S XMSUB="RAI/MDS HL7 BUILD ERROR"
+ S (XMDUZ,XMDUZ)="RAI/MDS APPLICATION"
+ ;
+ S XMB="DGRU RAI ERROR"
+ S XMB(1)=$$GET1^DIQ(2,@EVNTINFO@("DFN"),.01)
+ S XMB(2)=@EVNTINFO@("EVENT")
+ S XMB(3)=">>> "_$P(RESULT,"^",2)
+ S XMB(4)=@EVNTINFO@("USER")
+ S XMB(5)=$$FMTE^XLFDT(@EVNTINFO@("DATE"))
+ S XMDT=DT
+ D ^XMB
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL.m	(revision 623)
@@ -1,94 +1,86 @@
-DGRUUTL	;ALB/GRR - RAI/MDS UTILITY ROUTINE ; 10/11/07 8:42am
-	;;5.3;Registration;**190,444,762**;Aug 13, 1993;Build 3
-HLNAME(DGNAME)	;Piece apart name into LAST NAME_"^"_FIRST NAME_"^"_MIDDLE NAME_"^"_SUFFIX
-	;Input DGNAME - Either Last Name, First or First, Middle and Last Name (i.e. SMITH,JOHN R   or  JOHN R SMITH)
-	S (DGFN,DGMN,DGLN,DGSUF,P1,P2,P3,P4)=""
-	I DGNAME'["," S P=$L(DGNAME," ") F Z=1:1:P S @("P"_Z)=$P(DGNAME," ",Z)
-	I DGNAME["," D
-	.S P1=$P(DGNAME,","),P2=$P(DGNAME,",",2),DGN=P2_" "_P1
-	.S P=$L(DGN," ") F Z=1:1:P S @("P"_Z)=$P(DGN," ",Z)
-	S DGSUF=$$SUF(@("P"_P))
-	I DGSUF'="" S P=P-1
-	I P=4 S DGFN=P1,DGMN=P2,DGLN=P3_" "_P4 G NAMQ
-	I P=3 D  G NAMQ
-	.I $L($P(P2,"."))=1 S DGFN=P1,DGMN=P2,DGLN=P3 Q
-	.I $L($P(P2,"."))=2 S DGFN=P1,DGLN=P2_" "_P3 Q
-	.S DGFN=P1,DGMN=P2,DGLN=P3
-	S DGFN=P1,DGLN=P2
-NAMQ	Q DGLN_"^"_DGFN_"^"_DGMN_"^"_DGSUF
-	;
-SUF(X)	;COMPARES PASSED DATA TO LIST OF SUFFIX'S AND RETURNS A FOUND SUFFIX OR NULL
-	I "^JR.^SR.^II.^III.^IV.^V.^VI.^VII.^VIII.^VIIII.^IX.^X."'[X Q ""
-	Q X
-	;
-CHKWARD(X)	;RETURNS 1 IF RAI/MDS WARD AND 0 IF NOT
-	;;Input X - Internal Entry Number of Ward in Ward file (#42)
-	;
-	Q $S(+X>0:+($$GET1^DIQ(42,X,.035,"I")),1:0)
-	;
-MEDICARE(DFN)	;Will retrieve the patient's Medicare Number and return it or return null
-	;Input - DFN patient's IEN
-	N DGSUB ;modified p-444
-	Q:DFN']"" ""  ;p-444
-	S DGSUB=$$HICN^IBCNSU1(DFN) ;p-444
-	Q:DGSUB<0 ""  ;no medicare number  p-444
-	Q DGSUB
-	;
-MEDICAID(DFN)	;Will retrieve the patient's Medicaid Number and return it or a null
-	;Input - DFN patient's IEN
-	;
-	;  Returns the medicaid information from the patient file
-	; P-762 return Medicaid number or 'N'
-	N A S A=$$GET1^DIQ(2,DFN,.383)
-	S:A="" A="N"
-	Q A
-	;
-GETAMOV(DFN)	;GET LAST ADMISSION MOVEMENT FOR A PATIENT
-	;
-	N I,J S (I,J)=""
-	S I=$O(^DGPM("ATID1",DFN,I)) Q:I="" ""
-	S J=$O(^DGPM("ATID1",DFN,I,J)) ;ien of admission movement
-	Q J
-	;
-RELATE(X)	;CONVERT FREE TEXT RELATIONSHIP TO RELATIONSHIP FILE ENTRY NUMBER AND NAME
-	N DIC,Y
-	S X=$$UPPER^HLFNC(X)
-	S X=$S(X="WIFE":"SPOUSE",X="HUSBAND":"SPOUSE",1:X)
-	S DIC="^DG(408.11,",DIC(0)="X" D ^DIC
-	S:Y<0 Y="99^OTHER" ;DEFAULT IF NOT FOUND IN FILE
-	Q Y
-	;
-ENC(DGRSEG,DGRMNMT,DGRFLN,DGRFLNM,DGROLDN,DGRNDATA,DGRSIED,DGCIEN)	;CREATE AND SEND MASTER FILE UPDATE HL7 MESSAGE
-	;INPUT:
-	;     DGRSEG  -  File Number
-	;     DGRMNMT -  Message Type (ie INSURANCE)
-	;     DGRFLN  -  Vista File Number (ie 36)
-	;     DGRFLNM -  Vista File Name (ie INSURANCE COMPANY)
-	;     DGROLDN -  Old Name value
-	;     DGRNDATA - New value (ie BLUE CROSS NH/VT)
-	;     DGRSIED -  Server Protocol IEN
-	;     DGRUHLP -  Priority of Message (ie I = Immediate)
-	;
-	Q:DGRSEG=""!(DGRMNMT="")!(DGRFLN="")!(DGRFLNM="")!(DGRNDATA="")!(DGRSIED="")  ;Quit if all parameters not passed
-	D EN^DGRUGMFU(DGRSEG,DGRMNMT,DGRFLN,DGRFLNM,DGROLDN,DGRNDATA,DGCIEN) ;Call routine which formats the Master File Update
-	I $D(^TMP($J,"DGRUGMFU",1)) D  ;If a Master File Update was created, do the following
-	.M HLA("HLS")=^TMP($J,"DGRUGMFU") ;Move global array maintaining HL7 message to local array
-	.D GENERATE^HLMA("DGRU-RAI-MFU-SERVER","LM",1,.DGRUET,"") ;Call API to generate the HL7 message
-	Q
-SENDMFU()	;Function to determine if master file updates should be sent
-	Q $P($G(^DG(43,1,"HL7")),"^",4)=1
-	;
-DOCID(X)	;Insure provider ID not greater than 6 digits
-	Q:$E(X,1,3)'="PV1" -1
-	N DGDOC,DGNIEN,IEN
-	S DGDOC=$P(X,HL("FS"),8),IEN=$P(DGDOC,$E(HL("ECH")))
-	I $L(IEN)<7 G EXITDOC
-	S DGNIEN=$E(IEN,$L(IEN)-5,$L(IEN)),$P(DGDOC,$E(HL("ECH")))=DGNIEN
-	S $P(X,HL("FS"),8)=DGDOC
-EXITDOC	Q X
-	;
-ATTDOC(X)	;get attending physician - p-762
-	N ATTPTR,ATTNAME,VAIP D IN5^VADPT S ATTPTR=$P(VAIP(18),"^",1),ATTNAME=$P(VAIP(18),"^",2) K VAIP
-	I $L(ATTPTR)>6 S ATTPTR=$E(ATTPTR,$L(ATTPTR)-5,$L(ATTPTR))
-	I $G(ATTNAME) S ATTNAME=$$HLNAME(ATTNAME)
-	Q ATTPTR_$E(HL("ECH"))_ATTNAME
+DGRUUTL ;ALB/GRR - RAI/MDS UTILITY ROUTINE
+ ;;5.3;Registration;**190,444**;Aug 13, 1993
+HLNAME(DGNAME) ;Piece apart name into LAST NAME_"^"_FIRST NAME_"^"_MIDDLE NAME_"^"_SUFFIX
+ ;Input DGNAME - Either Last Name, First or First, Middle and Last Name (i.e. SMITH,JOHN R   or  JOHN R SMITH)
+ S (DGFN,DGMN,DGLN,DGSUF,P1,P2,P3,P4)=""
+ I DGNAME'["," S P=$L(DGNAME," ") F Z=1:1:P S @("P"_Z)=$P(DGNAME," ",Z)
+ I DGNAME["," D
+ .S P1=$P(DGNAME,","),P2=$P(DGNAME,",",2),DGN=P2_" "_P1
+ .S P=$L(DGN," ") F Z=1:1:P S @("P"_Z)=$P(DGN," ",Z)
+ S DGSUF=$$SUF(@("P"_P))
+ I DGSUF'="" S P=P-1
+ I P=4 S DGFN=P1,DGMN=P2,DGLN=P3_" "_P4 G NAMQ
+ I P=3 D  G NAMQ
+ .I $L($P(P2,"."))=1 S DGFN=P1,DGMN=P2,DGLN=P3 Q
+ .I $L($P(P2,"."))=2 S DGFN=P1,DGLN=P2_" "_P3 Q
+ .S DGFN=P1,DGMN=P2,DGLN=P3
+ S DGFN=P1,DGLN=P2
+NAMQ Q DGLN_"^"_DGFN_"^"_DGMN_"^"_DGSUF
+ ;
+SUF(X) ;COMPARES PASSED DATA TO LIST OF SUFFIX'S AND RETURNS A FOUND SUFFIX OR NULL
+ I "^JR.^SR.^II.^III.^IV.^V.^VI.^VII.^VIII.^VIIII.^IX.^X."'[X Q ""
+ Q X
+ ;
+CHKWARD(X) ;RETURNS 1 IF RAI/MDS WARD AND 0 IF NOT
+ ;;Input X - Internal Entry Number of Ward in Ward file (#42)
+ ;
+ Q $S(+X>0:+($$GET1^DIQ(42,X,.035,"I")),1:0)
+ ;
+MEDICARE(DFN) ;Will retrieve the patient's Medicare Number and return it or return null
+ ;Input - DFN patient's IEN
+ N DGSUB ;modified p-444
+ Q:DFN']"" ""  ;p-444
+ S DGSUB=$$HICN^IBCNSU1(DFN) ;p-444
+ Q:DGSUB<0 ""  ;no medicare number  p-444
+ Q DGSUB
+ ;
+MEDICAID(DFN) ;Will retrieve the patient's Medicaid Number and return it or a null
+ ;Input - DFN patient's IEN
+ ;
+ ;  Returns the medicaid information from the patient file
+ Q $$GET1^DIQ(2,DFN,.383)
+ ;
+GETAMOV(DFN) ;GET LAST ADMISSION MOVEMENT FOR A PATIENT
+ ;
+ N I,J S (I,J)=""
+ S I=$O(^DGPM("ATID1",DFN,I)) Q:I="" ""
+ S J=$O(^DGPM("ATID1",DFN,I,J)) ;ien of admission movement
+ Q J
+ ;
+RELATE(X) ;CONVERT FREE TEXT RELATIONSHIP TO RELATIONSHIP FILE ENTRY NUMBER AND NAME
+ N DIC,Y
+ S X=$$UPPER^HLFNC(X)
+ S X=$S(X="WIFE":"SPOUSE",X="HUSBAND":"SPOUSE",1:X)
+ S DIC="^DG(408.11,",DIC(0)="X" D ^DIC
+ S:Y<0 Y="99^OTHER" ;DEFAULT IF NOT FOUND IN FILE
+ Q Y
+ ;
+ENC(DGRSEG,DGRMNMT,DGRFLN,DGRFLNM,DGROLDN,DGRNDATA,DGRSIED,DGCIEN) ;CREATE AND SEND MASTER FILE UPDATE HL7 MESSAGE
+ ;INPUT:
+ ;     DGRSEG  -  File Number
+ ;     DGRMNMT -  Message Type (ie INSURANCE)
+ ;     DGRFLN  -  Vista File Number (ie 36)
+ ;     DGRFLNM -  Vista File Name (ie INSURANCE COMPANY)
+ ;     DGROLDN -  Old Name value
+ ;     DGRNDATA - New value (ie BLUE CROSS NH/VT)
+ ;     DGRSIED -  Server Protocol IEN
+ ;     DGRUHLP -  Priority of Message (ie I = Immediate)
+ ;
+ Q:DGRSEG=""!(DGRMNMT="")!(DGRFLN="")!(DGRFLNM="")!(DGRNDATA="")!(DGRSIED="")  ;Quit if all parameters not passed
+ D EN^DGRUGMFU(DGRSEG,DGRMNMT,DGRFLN,DGRFLNM,DGROLDN,DGRNDATA,DGCIEN) ;Call routine which formats the Master File Update
+ I $D(^TMP($J,"DGRUGMFU",1)) D  ;If a Master File Update was created, do the following
+ .M HLA("HLS")=^TMP($J,"DGRUGMFU") ;Move global array maintaining HL7 message to local array
+ .D GENERATE^HLMA("DGRU-RAI-MFU-SERVER","LM",1,.DGRUET,"") ;Call API to generate the HL7 message
+ Q
+SENDMFU() ;Function to determine if master file updates should be sent
+ Q $P($G(^DG(43,1,"HL7")),"^",4)=1
+ ;
+DOCID(X) ;Insure provider ID not greater than 6 digits
+ Q:$E(X,1,3)'="PV1" -1
+ N DGDOC,DGNIEN,IEN
+ S DGDOC=$P(X,HL("FS"),8),IEN=$P(DGDOC,$E(HL("ECH")))
+ I $L(IEN)<7 G EXITDOC
+ S DGNIEN=$E(IEN,$L(IEN)-5,$L(IEN)),$P(DGDOC,$E(HL("ECH")))=DGNIEN
+ S $P(X,HL("FS"),8)=DGDOC
+EXITDOC Q X
+ ;
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m	(revision 623)
@@ -1,233 +1,233 @@
-DPTLK	;ALB/RMO,RTK - MAS Patient Look-up Main Routine ;1/27/07  13:12
-	;;5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	;
-	; mods made for magstripe read 12/96 - JFP
-	;
-	;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
-	;                by patch DG*5.3*244
-	;
-EN	; -- Entry point
-	;Following line so VOE will use alternate lookup routine, DAOU,VA/CJS,WV/TOAD
-	I $G(DUZ("AG"))'="V" D ^AUPNLK Q
-	N DIE,DR
-	K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X)))
-	I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK
-	I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable to proceed. ",$S('$D(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"." G QK
-EN2	K DO,DUOUT,DTOUT S U="^",DIC="^DPT(",DIC(0)=$S($D(DIC(0)):DIC(0),1:"AELMQ") S:DIC(0)'["A" (DPTX,DPTSAVX)=X
-	S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ)
-	;
-ASKPAT	; -- Prompt for patient
-	I DIC(0)["A" D   G QK:'$T!($E(DPTX)["^")!(DPTX="")
-	.K DTOUT,DUOUT
-	.W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC("B")) DIC("B"),"// "
-	.R X:DTIME
-	.S DPTX=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^"&($E(DPTX)'="%") DUOUT=1
-	; -- Check for the IATA magnetic stripe input
-	N MAG,GCHK
-	S MAG=0
-	I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX)
-	;
-CHKPAT	; -- Custom Patient Lookup
-	D DO^DIC1
-	S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"")
-	K DPTIFNS,DPTS,DPTSEL
-	S DPTCNT=0
-	; -- Check input for format an length
-	G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30)
-	; -- Check for null response or abort
-	I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK
-	; -- Check for question mark
-	I DPTX["?" D  G ASKPAT:DIC(0)["A",QK
-	.S D="B"
-	.S DZ=$S(DPTX?1"?":"",1:"??")
-	.G CHKPAT1:DZ="??"
-	.N %
-	.W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of"
-	.W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER"
-	.W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN
-	.Q:%'=1
-	.S DZ="??"
-CHKPAT1	.S X=DPTX
-	.D DQ^DICQ
-	; -- Check for space bar, return
-	I DPTX=" " D  G CHKDFN
-	.S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)
-	.D SETDPT^DPTLK1:Y>0
-	.S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
-	; -- Check for DFN look up
-	I $E(DPTX)="`" D  G CHKDFN
-	.S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1)
-	.D SETDPT^DPTLK1:Y>0
-	.S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
-	; -- Puts input in correct format
-	G CHKDFN:DPTX=""
-	; -- Force new entry
-	I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT
-	; -- Check for index lookups
-	D ^DPTLK1 G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN
-MAG	; -- No patient found, check for mag stripe input, create stub
-	I 'MAG G NOPAT
-	; -- Check for ADT option(s) only
-	N DGOPT
-	S DGOPT=$P($G(XQY0),"^",2)
-	I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D  G EN2
-	.W !,"    ...Patient not in database, use ADT options to load patient" D Q1
-	; -- Prompt for creation of stub
-	S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: "
-	S GCHK=$D(^TMP("DGVIC"))
-	D ^DIR
-	K DIR
-	I 'Y D Q1 G EN2
-	; -- Parse IATA fields
-	D FIELDS(IATA)
-	; -- Check for Duplicates
-	D EP2^DPTLK3
-	I DPTDFN<0 D Q1 G EN2
-	; -- Creates Stub entry in patient file
-	S Y=$$FILE^DPTLK4(DGFLDS)
-	I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q
-	D QK1
-	Q
-	;
-NOPAT	; -- No patient found, ask to add new
-	I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G(DTOUT)),QK1
-	;
-CHKDFN	; -- 
-	S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q" *7," ??" G ASKPAT:DIC(0)["A",QK
-	I DIC(0)["E" D  W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS(DPTDFN),U,2)_"  "_$P(DPTS(DPTDFN),U)_"  ",$D(^DPT(DPTDFN,0)):"  "_$P(^(0),U)_"  ",1:"") S Y=DPTDFN X:$D(^DPT(DPTDFN,0)) "N DDS X DIC(""W"")"
-	.I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
-	;
-	; check for other patients in "BS5" xref on Patient file
-	I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D  G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0
-	.N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P(DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9)
-	.W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and"
-	.W !,"whose social security number ends with '",DPTSSN,"'."
-	.W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN
-	.I %'=1 S DPTDFN=-1
-	;
-	I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0
-	S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U)
-	;
-Q	; -- 
-	S Y=$S('$D(DPTDFN):-1,'$D(DPTS(+DPTDFN)):-1,1:DPTDFN),X=$S($D(DPTX)&(+Y>0):DPTX,$D(DPTSAVX):DPTSAVX,$D(DPTX):DPTX,1:"")
-	I Y>0 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)
-	;DG*600
-	;I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning : You have selected a test patient."
-	I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : You may have selected a test patient."
-	I DIC(0)["E",$$BADADR^DGUTL3(+Y) W *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator."
-	I DIC(0)["E",$$VAADV^DPTLK3(+Y) W *7,!,"** Patient is VA ADVANTAGE."
-	;DG*485
-	I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5
-	;Display enrollment information
-	I Y>0,DIC(0)["E" D ENR
-	;
-	;Call Combat Vet check
-	I Y>0,DIC(0)["E" D CV
-	;
-	; check whether to display Means Test Required message
-	D
-	.N DPTDIV
-	.I '$G(DUZ(2)) Q
-	.I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D
-	..W $C(7),!!,"MEANS TEST REQUIRED"
-	..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2)
-	..H 2
-	;
-Q1	; -- Clean up variables
-	K D,DIC("W"),DO,DPTCNT,DPTDFN,DPTIFNS,DPTIX,DPTS
-	K DPTSAVX,DPTSEL,DPTSZ,DPTX
-	;
-	K:$D(IATA) IATA
-	K:$D(DGFLDS) @DGFLDS,DGFLDS
-	Q
-	;
-QK	K:'$D(DPTNOFZK) DPTNOFZY G Q
-	;
-QK1	K:'$D(DPTNOFZK) DPTNOFZY G Q1
-	;
-IX	; --
-	I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D
-	G DPTLK
-	;
-IATA(X)	; --
-	;This function pulls off ssn from the IATA track
-	;
-	;Input:  X   -  what was read in
-	;Output: SSN -  social security number
-	;          Q -  quit
-	;
-	; Track            Start Sent     End Sent      Field Separator
-	; -----            ----------     --------      ---------------
-	;  IATA (alphanum)      %             ?          {   (Note: VA used ^)
-	;  ABA (numeric)        ;             ?          =    
-	;
-	;N IATA
-	S (IATA)=""
-	I $E(X)'="%" Q X ; no start sentinel
-	I X'["?" Q "Q"
-	; -- Extract data from track
-	S IATA=$$TRACK(X,"%","?")
-	; -- checks for no data
-	I IATA="" Q "Q"
-	; -- Returns SSN
-	I IATA'="" Q $P(IATA,"^")
-	Q "Q"
-	;
-TRACK(X,START,END)	; find track where start/end are sentinels
-	;
-	Q $P($P($G(X),START,2),END,1)
-	;
-FIELDS(IATA)	; -- Sets fields
-	Q:'$D(IATA)
-	N CNT,FIELD
-	S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1
-	K @DGFLDS
-	F  S FIELD=$P($G(IATA),"^",CNT)  Q:FIELD=""  D
-	.S @DGFLDS@(CNT)=FIELD
-	.S CNT=CNT+1
-	; -- Define fields for duplicate checker
-	S DPTX=$G(@DGFLDS@(2)) ;NAME
-	S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB
-	S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN
-	Q
-ENR	;Display Enrollment information after patient selection
-	N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT
-	I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q
-	S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN)
-	S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
-	W !?1,"Enrollment Priority: ",$S($G(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:""),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP"))))
-	W ?33,"Category: ",DGENCAT
-	W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR("END"),"5DZ"),1:""),!
-	;If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I)
-	I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS"))=20) D
-	. W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"") ;H 5
-	;check for Combat Veteran Eligibility, if elig do not display EGT info
-	I $$CVEDT^DGCV(+DPTDFN) Q
-	;Get Enrollment Group Threshold Priority and Subgroup
-	S DGEGTIEN=$$FINDCUR^DGENEGT
-	S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
-	Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="")
-	;Compare Patient's Enrollment Priority to Enrollment Group Threshold
-	I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP")) D
-	.N X,IORVOFF,IORVON
-	.S X="IORVOFF;IORVON"
-	.D ENDR^%ZISS
-	.W !?32 W:$D(IORVON) IORVON  W "*** WARNING ***" W:$D(IORVOFF) IORVOFF
-	.I DGENR("END")'="" W !?14 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT END",$S(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$$FMTE^XLFDT(DGENR("END"),"5DZ")," ***" W:$D(IORVOFF) IORVOFF Q
-	.W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING.  ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF
-	Q
-CV	;check for Combat Vet status
-	N DGCV
-	S DGCV=$$CVEDT^DGCV(+DPTDFN)
-	I $P(DGCV,U)=1 D  Q
-	. I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W !
-	. W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
-	Q
+DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ;1/27/07  13:12
+ ;;5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ;
+ ; mods made for magstripe read 12/96 - JFP
+ ;
+ ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
+ ;                by patch DG*5.3*244
+ ;
+EN ; -- Entry point
+ ;Following line so VOE will use alternate lookup routine, DAOU,VA/CJS,WV/TOAD
+ I $G(DUZ("AG"))'="V" D ^AUPNLK Q
+ N DIE,DR
+ K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X)))
+ I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK
+ I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable to proceed. ",$S('$D(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"." G QK
+EN2 K DO,DUOUT,DTOUT S U="^",DIC="^DPT(",DIC(0)=$S($D(DIC(0)):DIC(0),1:"AELMQ") S:DIC(0)'["A" (DPTX,DPTSAVX)=X
+ S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ)
+ ;
+ASKPAT ; -- Prompt for patient
+ I DIC(0)["A" D   G QK:'$T!($E(DPTX)["^")!(DPTX="")
+ .K DTOUT,DUOUT
+ .W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC("B")) DIC("B"),"// "
+ .R X:DTIME
+ .S DPTX=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^"&($E(DPTX)'="%") DUOUT=1
+ ; -- Check for the IATA magnetic stripe input
+ N MAG,GCHK
+ S MAG=0
+ I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX)
+ ;
+CHKPAT ; -- Custom Patient Lookup
+ D DO^DIC1
+ S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"")
+ K DPTIFNS,DPTS,DPTSEL
+ S DPTCNT=0
+ ; -- Check input for format an length
+ G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30)
+ ; -- Check for null response or abort
+ I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK
+ ; -- Check for question mark
+ I DPTX["?" D  G ASKPAT:DIC(0)["A",QK
+ .S D="B"
+ .S DZ=$S(DPTX?1"?":"",1:"??")
+ .G CHKPAT1:DZ="??"
+ .N %
+ .W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of"
+ .W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER"
+ .W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN
+ .Q:%'=1
+ .S DZ="??"
+CHKPAT1 .S X=DPTX
+ .D DQ^DICQ
+ ; -- Check for space bar, return
+ I DPTX=" " D  G CHKDFN
+ .S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)
+ .D SETDPT^DPTLK1:Y>0
+ .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
+ ; -- Check for DFN look up
+ I $E(DPTX)="`" D  G CHKDFN
+ .S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1)
+ .D SETDPT^DPTLK1:Y>0
+ .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
+ ; -- Puts input in correct format
+ G CHKDFN:DPTX=""
+ ; -- Force new entry
+ I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT
+ ; -- Check for index lookups
+ D ^DPTLK1 G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN
+MAG ; -- No patient found, check for mag stripe input, create stub
+ I 'MAG G NOPAT
+ ; -- Check for ADT option(s) only
+ N DGOPT
+ S DGOPT=$P($G(XQY0),"^",2)
+ I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D  G EN2
+ .W !,"    ...Patient not in database, use ADT options to load patient" D Q1
+ ; -- Prompt for creation of stub
+ S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: "
+ S GCHK=$D(^TMP("DGVIC"))
+ D ^DIR
+ K DIR
+ I 'Y D Q1 G EN2
+ ; -- Parse IATA fields
+ D FIELDS(IATA)
+ ; -- Check for Duplicates
+ D EP2^DPTLK3
+ I DPTDFN<0 D Q1 G EN2
+ ; -- Creates Stub entry in patient file
+ S Y=$$FILE^DPTLK4(DGFLDS)
+ I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q
+ D QK1
+ Q
+ ;
+NOPAT ; -- No patient found, ask to add new
+ I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G(DTOUT)),QK1
+ ;
+CHKDFN ; -- 
+ S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q" *7," ??" G ASKPAT:DIC(0)["A",QK
+ I DIC(0)["E" D  W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS(DPTDFN),U,2)_"  "_$P(DPTS(DPTDFN),U)_"  ",$D(^DPT(DPTDFN,0)):"  "_$P(^(0),U)_"  ",1:"") S Y=DPTDFN X:$D(^DPT(DPTDFN,0)) "N DDS X DIC(""W"")"
+ .I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
+ ;
+ ; check for other patients in "BS5" xref on Patient file
+ I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D  G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0
+ .N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P(DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9)
+ .W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and"
+ .W !,"whose social security number ends with '",DPTSSN,"'."
+ .W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN
+ .I %'=1 S DPTDFN=-1
+ ;
+ I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0
+ S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U)
+ ;
+Q ; -- 
+ S Y=$S('$D(DPTDFN):-1,'$D(DPTS(+DPTDFN)):-1,1:DPTDFN),X=$S($D(DPTX)&(+Y>0):DPTX,$D(DPTSAVX):DPTSAVX,$D(DPTX):DPTX,1:"")
+ I Y>0 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)
+ ;DG*600
+ ;I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning : You have selected a test patient."
+ I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : You may have selected a test patient."
+ I DIC(0)["E",$$BADADR^DGUTL3(+Y) W *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator."
+ I DIC(0)["E",$$VAADV^DPTLK3(+Y) W *7,!,"** Patient is VA ADVANTAGE."
+ ;DG*485
+ I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5
+ ;Display enrollment information
+ I Y>0,DIC(0)["E" D ENR
+ ;
+ ;Call Combat Vet check
+ I Y>0,DIC(0)["E" D CV
+ ;
+ ; check whether to display Means Test Required message
+ D
+ .N DPTDIV
+ .I '$G(DUZ(2)) Q
+ .I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D
+ ..W $C(7),!!,"MEANS TEST REQUIRED"
+ ..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2)
+ ..H 2
+ ;
+Q1 ; -- Clean up variables
+ K D,DIC("W"),DO,DPTCNT,DPTDFN,DPTIFNS,DPTIX,DPTS
+ K DPTSAVX,DPTSEL,DPTSZ,DPTX
+ ;
+ K:$D(IATA) IATA
+ K:$D(DGFLDS) @DGFLDS,DGFLDS
+ Q
+ ;
+QK K:'$D(DPTNOFZK) DPTNOFZY G Q
+ ;
+QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1
+ ;
+IX ; --
+ I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D
+ G DPTLK
+ ;
+IATA(X) ; --
+ ;This function pulls off ssn from the IATA track
+ ;
+ ;Input:  X   -  what was read in
+ ;Output: SSN -  social security number
+ ;          Q -  quit
+ ;
+ ; Track            Start Sent     End Sent      Field Separator
+ ; -----            ----------     --------      ---------------
+ ;  IATA (alphanum)      %             ?          {   (Note: VA used ^)
+ ;  ABA (numeric)        ;             ?          =    
+ ;
+ ;N IATA
+ S (IATA)=""
+ I $E(X)'="%" Q X ; no start sentinel
+ I X'["?" Q "Q"
+ ; -- Extract data from track
+ S IATA=$$TRACK(X,"%","?")
+ ; -- checks for no data
+ I IATA="" Q "Q"
+ ; -- Returns SSN
+ I IATA'="" Q $P(IATA,"^")
+ Q "Q"
+ ;
+TRACK(X,START,END) ; find track where start/end are sentinels
+ ;
+ Q $P($P($G(X),START,2),END,1)
+ ;
+FIELDS(IATA) ; -- Sets fields
+ Q:'$D(IATA)
+ N CNT,FIELD
+ S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1
+ K @DGFLDS
+ F  S FIELD=$P($G(IATA),"^",CNT)  Q:FIELD=""  D
+ .S @DGFLDS@(CNT)=FIELD
+ .S CNT=CNT+1
+ ; -- Define fields for duplicate checker
+ S DPTX=$G(@DGFLDS@(2)) ;NAME
+ S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB
+ S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN
+ Q
+ENR ;Display Enrollment information after patient selection
+ N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT
+ I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q
+ S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN)
+ S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
+ W !?1,"Enrollment Priority: ",$S($G(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:""),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP"))))
+ W ?33,"Category: ",DGENCAT
+ W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR("END"),"5DZ"),1:""),!
+ ;If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I)
+ I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS"))=20) D
+ . W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"") ;H 5
+ ;check for Combat Veteran Eligibility, if elig do not display EGT info
+ I $$CVEDT^DGCV(+DPTDFN) Q
+ ;Get Enrollment Group Threshold Priority and Subgroup
+ S DGEGTIEN=$$FINDCUR^DGENEGT
+ S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
+ Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="")
+ ;Compare Patient's Enrollment Priority to Enrollment Group Threshold
+ I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP")) D
+ .N X,IORVOFF,IORVON
+ .S X="IORVOFF;IORVON"
+ .D ENDR^%ZISS
+ .W !?32 W:$D(IORVON) IORVON  W "*** WARNING ***" W:$D(IORVOFF) IORVOFF
+ .I DGENR("END")'="" W !?14 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT END",$S(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$$FMTE^XLFDT(DGENR("END"),"5DZ")," ***" W:$D(IORVOFF) IORVOFF Q
+ .W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING.  ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF
+ Q
+CV ;check for Combat Vet status
+ N DGCV
+ S DGCV=$$CVEDT^DGCV(+DPTDFN)
+ I $P(DGCV,U)=1 D  Q
+ . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W !
+ . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADATE.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADATE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADATE.m	(revision 623)
@@ -1,16 +1,16 @@
-VADATE	;ALB/MLI - GENERIC DATE ROUTINE ; 1 DEC 88 @1000
-	;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
-	;
-	I $D(VADAT("F")),$S(VADAT("F")<1:1,VADAT("F")>2:1,1:0) K VADAT("F")
-	I '$D(VADAT("W")) S VANOW=$$NOW^XLFDT
-	S VA=$S('$D(VADAT("W")):VANOW,1:VADAT("W")),(VA,VADATE("I"))=$S($D(VADAT("S")):VA,'$D(VADAT("T")):$E(VA,1,12),1:$P(VA,".",1))
-	S:'$D(VADAT("H")) (VA(1),VA(2),VA(3))=1 I $D(VADAT("H")) F I=1:1:3 S VA(I)=$S(VADAT("H")[I:1,1:0)
-	S VAM=$S('$E(VA,4,5):"",'VA(2):"",$S('$D(VADAT("F")):1,VADAT("F")=2:1,1:0):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(VA,4,5)),1:$E(VA,4,5)),VAY=$S(VA(3):(1700+$E(VA,1,3)),1:""),VAD=$S(VA(1)&$E(VA,6,7):$E(VA,6,7),1:"")
-	I $P(VA,".",2)]"" S VA=$P(VA,".",2),VAT=$E(VA_"000000",1,2)_":"_$E(VA_"000000",3,4) S:$D(VADAT("S")) VAT=VAT_":"_$E(VA_"000000",5,6)
-	I '$D(VADAT("F")) S VADATE("E")=VAM_$S(VAM]""&(VAD!VAY):" ",1:"")_$S(VAD:$J(+VAD,2),1:"")_$S(VAD&VAY:",",1:"")_VAY_$S($D(VAT):"@"_VAT,1:"") G QUIT
-	S VADEL=$S('$D(VADAT("D")):"-",1:VADAT("D")) I VADAT("F")=1 S VADATE("E")=$S('VA(2):"",VAM]"":VAM,1:"00")_$S(VA(1)&VA(2):VADEL,1:"")_$S('VA(1):"",VAD]"":VAD,1:"00")_$S((VA(1)!VA(2))&VA(3):VADEL,1:"")
-	I VADAT("F")=2 S VADATE("E")=$S('VA(1):"",VAD]"":VAD,1:"00")_$S(VA(1)&VA(2):VADEL,1:"")_$S('VA(2):"",VAM]"":VAM,1:"XXX")_$S((VA(1)!VA(2))&VA(3):VADEL,1:"")
-	S VADATE("E")=VADATE("E")_$S(VA(3):$E(VAY,3,4),1:"")_$S($D(VAT):"@"_VAT,1:"")
-QUIT	I $D(VADAT("J")),VADAT("J")?.N F I=$L(VADATE("E"))+1:1:VADAT("J") S VADATE("E")=" "_VADATE("E")
-	K %DT,VA,VAD,VADEL,VAM,VAT,VAX,VAY,VANOW Q
-KVAR	K VADAT,VADATE Q
+VADATE ;ALB/MLI - GENERIC DATE ROUTINE ; 1 DEC 88 @1000
+ ;;5.3;Registration;;Aug 13, 1993
+ ;
+ I $D(VADAT("F")),$S(VADAT("F")<1:1,VADAT("F")>2:1,1:0) K VADAT("F")
+ I '$D(VADAT("W")) D NOW^%DTC
+ S VA=$S('$D(VADAT("W")):%,1:VADAT("W")),(VA,VADATE("I"))=$S($D(VADAT("S")):VA,'$D(VADAT("T")):$E(VA,1,12),1:$P(VA,".",1))
+ S:'$D(VADAT("H")) (VA(1),VA(2),VA(3))=1 I $D(VADAT("H")) F I=1:1:3 S VA(I)=$S(VADAT("H")[I:1,1:0)
+ S VAM=$S('$E(VA,4,5):"",'VA(2):"",$S('$D(VADAT("F")):1,VADAT("F")=2:1,1:0):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(VA,4,5)),1:$E(VA,4,5)),VAY=$S(VA(3):(1700+$E(VA,1,3)),1:""),VAD=$S(VA(1)&$E(VA,6,7):$E(VA,6,7),1:"")
+ I $P(VA,".",2)]"" S VA=$P(VA,".",2),VAT=$E(VA_"000000",1,2)_":"_$E(VA_"000000",3,4) S:$D(VADAT("S")) VAT=VAT_":"_$E(VA_"000000",5,6)
+ I '$D(VADAT("F")) S VADATE("E")=VAM_$S(VAM]""&(VAD!VAY):" ",1:"")_$S(VAD:$J(+VAD,2),1:"")_$S(VAD&VAY:",",1:"")_VAY_$S($D(VAT):"@"_VAT,1:"") G QUIT
+ S VADEL=$S('$D(VADAT("D")):"-",1:VADAT("D")) I VADAT("F")=1 S VADATE("E")=$S('VA(2):"",VAM]"":VAM,1:"00")_$S(VA(1)&VA(2):VADEL,1:"")_$S('VA(1):"",VAD]"":VAD,1:"00")_$S((VA(1)!VA(2))&VA(3):VADEL,1:"")
+ I VADAT("F")=2 S VADATE("E")=$S('VA(1):"",VAD]"":VAD,1:"00")_$S(VA(1)&VA(2):VADEL,1:"")_$S('VA(2):"",VAM]"":VAM,1:"XXX")_$S((VA(1)!VA(2))&VA(3):VADEL,1:"")
+ S VADATE("E")=VADATE("E")_$S(VA(3):$E(VAY,3,4),1:"")_$S($D(VAT):"@"_VAT,1:"")
+QUIT I $D(VADAT("J")),VADAT("J")?.N F I=$L(VADATE("E"))+1:1:VADAT("J") S VADATE("E")=" "_VADATE("E")
+ K %DT,VA,VAD,VADEL,VAM,VAT,VAX,VAY Q
+KVAR K VADAT,VADATE Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m	(revision 623)
@@ -1,164 +1,164 @@
-VADPT1	;ALB/MRL/MJK - PATIENT VARIABLES ;1/27/07  15:00
-	;;5.3;Registration;**415,489,516,614,634**;Aug 13, 1993;Build 30
-	; Modified from FOIA VISTA,
-	; Copyright (C) 2007 WorldVistA
-	;
-	; This program is free software; you can redistribute it and/or modify
-	; it under the terms of the GNU General Public License as published by
-	; the Free Software Foundation; either version 2 of the License, or
-	; (at your option) any later version.
-	;
-	; This program is distributed in the hope that it will be useful,
-	; but WITHOUT ANY WARRANTY; without even the implied warranty of
-	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-	; GNU General Public License for more details.
-	;
-	; You should have received a copy of the GNU General Public License
-	; along with this program; if not, write to the Free Software
-	; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-1	;Demographic [DEM]
-	N W,Z,NODE
-	;
-	; -- name [1 - NM]
-	S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^")
-	;
-	; -- ssn [2 - SS]
-	S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"")
-	;
-	; -- date of birth [2 - DB]
-	S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y
-	;
-	; -- age [4 - AG]
-	S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
-	;
-	; Added for VOE to support pediatrics
-	;
-	I @VAV@($P(VAS,"^",4))<2 D  ;IHS/ANMC/CLS 01/20/2005
-	.N X,X1,X2,X3
-	.S X1=$S('$G(^DPT(DFN,.35)):DT,1:+^(.35))
-	.S X2=$P(VAX,"^",3) Q:'X1!('X2)
-	.D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,X<31:X_" DYS",1:X\30_" MOS")
-	.S @VAV@($P(VAS,"^",4))=X Q
-	;
-	; End VOE addition
-	;
-	;
-	; -- expired date [6 - EX]
-	S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y
-	;
-	; -- sex [5 - SX]
-	S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z
-	;
-	; -- remarks [7 - RE]
-	S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10)
-	;
-	; -- historic race [8 - RA]
-	S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"")
-	;
-	; -- religion [9 - RP]
-	S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"")
-	;
-	; -- marital status [10 - MS]
-	S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"")
-	;
-	; -- ethnicity [11 - ET]
-	S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X  D
-	.S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D
-	..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1)
-	..; -- collection method
-	..S Z=$P(NODE,"^",2) I Z D
-	...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
-	S @VAV@($P(VAS,"^",11))=Y-1
-	;
-	; -- race [12 - RC]
-	S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X  D
-	.S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D
-	..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1)
-	..; -- collection method
-	..S Z=$P(NODE,"^",2) I Z D
-	...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
-	S @VAV@($P(VAS,"^",12))=Y-1
-	Q
-	;
-	; Added for VOE to support pediatrics
-	;
-PAGE	; -- IHS printable age  ;IHS/ITSC/CLS 01/14/2005
-	N X,X1,X2,Y,AUX
-	S X1=$S('$D(^DPT(DFN,.35)):DT,1:+^(.35))
-	S X2=$P(VAX,"^",3) D:X2 ^%DTC:X1 S AUX=X\365.25,X=$S(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
-	S @VAV@($P(VAS,"^",4))=X Q
-	;
-	; End addition for VOE & IHS
-	;
-2	;Other Patient Variables [OPD]
-	N W,Z
-	S VAX=^DPT(DFN,0)
-	;
-	; -- city of birth [1 - BC]
-	S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11)
-	;
-	; -- state of birth [2 - BS]
-	S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"")
-	;
-	; -- occupation [6 - OC]
-	S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7)
-	;
-	; -- names
-	S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"")
-	S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's        [3 - FN]
-	S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's        [4 - MN]
-	S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM]
-	;
-	; -- employment status [7 - ES]
-	S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
-	S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"")
-	Q
-	;
-3	;Address [ADD]
-	S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
-	I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)<VAEND) S VAX=$S($D(^DPT(DFN,.11)):^(.11),1:""),VAX(1)=0
-	E  S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""),VAX(1)=1
-	F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I))=VAZ I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",5))=@VAV@($P(VAS,"^",5))_"^"_VAZ
-	S VAZ=$S('VAX(1):$P(VAX,"^",7),1:$P(VAX,"^",11)) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",7))=VAZ
-	S VAZIP4=$P(VAX,U,12)
-	S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
-	;DG*5.3*516
-	I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",1)
-	I 'VAX(1) G CA
-	S @VAV@($P(VAS,"^",8))=$P(VAX,"^",10)
-	F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+2))=VAZ_"^"_Y
-CA	;Confidential Address
-	I '$D(^DPT(DFN,.141)) G Q3
-	N VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
-	S VAX=$S($D(^DPT(DFN,.141)):^(.141),1:"")
-	S VAACTDT=$S($D(VAPA("CD")):VAPA("CD"),1:DT)
-	F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I+12))=VAZ D
-	.I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_VAZ Q
-	.I I=6,($G(VAZ)]"") S @VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_$S(($L(VAZ)=5):VAZ,1:$E(VAZ,1,5)_"-"_$E(VAZ,6,9))
-	S VAZ=$P(VAX,"^",11) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",19))=VAZ
-	F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+13))=VAZ_"^"_Y
-	S VABEG=$P(VAX,"^",7),VAEND=$P(VAX,"^",8)
-	S @VAV@($P(VAS,"^",12))=1
-	I 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT)) S @VAV@($P(VAS,"^",12))=0
-	I $D(^DPT(DFN,.14)) D
-	.S VACAN="" F  S VACAN=$O(^DPT(DFN,.14,VACAN)) Q:VACAN=""  D
-	..Q:'$D(^DPT(DFN,.14,VACAN,0))
-	..S VATYP=$P(^DPT(DFN,.14,VACAN,0),"^",1),VAACT=$P(^DPT(DFN,.14,VACAN,0),"^",2)
-	..S VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
-	..S VATYPNAM="" F I=1:1 S VATYPNAM=$P(VACAT,";",I) Q:VATYPNAM=""  D
-	...I +VATYPNAM[VATYP S VATYPNAM=$P(VATYPNAM,":",2),@VAV@($P(VAS,"^",22),VATYP)=VATYP_"^"_VATYPNAM_"^"_VAACT
-Q3	K VABEG,VAEND,VAZIP4 Q
-	;
-4	;Other Address [OAD]
-	N VAZIP4
-	I $S('$D(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0) S VAX=.21,VAOA("A")=7
-	E  S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A"))
-	S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99)
-	S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
-	S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8
-	F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
-	I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))=""
-	S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1)
-	S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A"))
-	S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
-	Q
+VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ;1/27/07  15:00
+ ;;5.3;Registration;**415,489,516,614,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+1 ;Demographic [DEM]
+ N W,Z,NODE
+ ;
+ ; -- name [1 - NM]
+ S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^")
+ ;
+ ; -- ssn [2 - SS]
+ S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"")
+ ;
+ ; -- date of birth [2 - DB]
+ S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y
+ ;
+ ; -- age [4 - AG]
+ S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
+ ;
+ ; Added for VOE to support pediatrics
+ ;
+ I @VAV@($P(VAS,"^",4))<2 D  ;IHS/ANMC/CLS 01/20/2005
+ .N X,X1,X2,X3
+ .S X1=$S('$G(^DPT(DFN,.35)):DT,1:+^(.35))
+ .S X2=$P(VAX,"^",3) Q:'X1!('X2)
+ .D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,X<31:X_" DYS",1:X\30_" MOS")
+ .S @VAV@($P(VAS,"^",4))=X Q
+ ;
+ ; End VOE addition
+ ;
+ ;
+ ; -- expired date [6 - EX]
+ S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y
+ ;
+ ; -- sex [5 - SX]
+ S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z
+ ;
+ ; -- remarks [7 - RE]
+ S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10)
+ ;
+ ; -- historic race [8 - RA]
+ S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"")
+ ;
+ ; -- religion [9 - RP]
+ S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"")
+ ;
+ ; -- marital status [10 - MS]
+ S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"")
+ ;
+ ; -- ethnicity [11 - ET]
+ S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X  D
+ .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D
+ ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1)
+ ..; -- collection method
+ ..S Z=$P(NODE,"^",2) I Z D
+ ...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
+ S @VAV@($P(VAS,"^",11))=Y-1
+ ;
+ ; -- race [12 - RC]
+ S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X  D
+ .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D
+ ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1)
+ ..; -- collection method
+ ..S Z=$P(NODE,"^",2) I Z D
+ ...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
+ S @VAV@($P(VAS,"^",12))=Y-1
+ Q
+ ;
+ ; Added for VOE to support pediatrics
+ ;
+PAGE ; -- IHS printable age  ;IHS/ITSC/CLS 01/14/2005
+ N X,X1,X2,Y,AUX
+ S X1=$S('$D(^DPT(DFN,.35)):DT,1:+^(.35))
+ S X2=$P(VAX,"^",3) D:X2 ^%DTC:X1 S AUX=X\365.25,X=$S(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
+ S @VAV@($P(VAS,"^",4))=X Q
+ ;
+ ; End addition for VOE & IHS
+ ;
+2 ;Other Patient Variables [OPD]
+ N W,Z
+ S VAX=^DPT(DFN,0)
+ ;
+ ; -- city of birth [1 - BC]
+ S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11)
+ ;
+ ; -- state of birth [2 - BS]
+ S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"")
+ ;
+ ; -- occupation [6 - OC]
+ S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7)
+ ;
+ ; -- names
+ S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"")
+ S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's        [3 - FN]
+ S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's        [4 - MN]
+ S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM]
+ ;
+ ; -- employment status [7 - ES]
+ S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
+ S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"")
+ Q
+ ;
+3 ;Address [ADD]
+ S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
+ I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)<VAEND) S VAX=$S($D(^DPT(DFN,.11)):^(.11),1:""),VAX(1)=0
+ E  S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""),VAX(1)=1
+ F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I))=VAZ I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",5))=@VAV@($P(VAS,"^",5))_"^"_VAZ
+ S VAZ=$S('VAX(1):$P(VAX,"^",7),1:$P(VAX,"^",11)) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",7))=VAZ
+ S VAZIP4=$P(VAX,U,12)
+ S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
+ ;DG*5.3*516
+ I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",1)
+ I 'VAX(1) G CA
+ S @VAV@($P(VAS,"^",8))=$P(VAX,"^",10)
+ F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+2))=VAZ_"^"_Y
+CA ;Confidential Address
+ I '$D(^DPT(DFN,.141)) G Q3
+ N VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
+ S VAX=$S($D(^DPT(DFN,.141)):^(.141),1:"")
+ S VAACTDT=$S($D(VAPA("CD")):VAPA("CD"),1:DT)
+ F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I+12))=VAZ D
+ .I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_VAZ Q
+ .I I=6,($G(VAZ)]"") S @VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_$S(($L(VAZ)=5):VAZ,1:$E(VAZ,1,5)_"-"_$E(VAZ,6,9))
+ S VAZ=$P(VAX,"^",11) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",19))=VAZ
+ F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+13))=VAZ_"^"_Y
+ S VABEG=$P(VAX,"^",7),VAEND=$P(VAX,"^",8)
+ S @VAV@($P(VAS,"^",12))=1
+ I 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT)) S @VAV@($P(VAS,"^",12))=0
+ I $D(^DPT(DFN,.14)) D
+ .S VACAN="" F  S VACAN=$O(^DPT(DFN,.14,VACAN)) Q:VACAN=""  D
+ ..Q:'$D(^DPT(DFN,.14,VACAN,0))
+ ..S VATYP=$P(^DPT(DFN,.14,VACAN,0),"^",1),VAACT=$P(^DPT(DFN,.14,VACAN,0),"^",2)
+ ..S VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
+ ..S VATYPNAM="" F I=1:1 S VATYPNAM=$P(VACAT,";",I) Q:VATYPNAM=""  D
+ ...I +VATYPNAM[VATYP S VATYPNAM=$P(VATYPNAM,":",2),@VAV@($P(VAS,"^",22),VATYP)=VATYP_"^"_VATYPNAM_"^"_VAACT
+Q3 K VABEG,VAEND,VAZIP4 Q
+ ;
+4 ;Other Address [OAD]
+ N VAZIP4
+ I $S('$D(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0) S VAX=.21,VAOA("A")=7
+ E  S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A"))
+ S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99)
+ S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
+ S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8
+ F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
+ I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))=""
+ S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1)
+ S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A"))
+ S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT2.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT2.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT2.m	(revision 623)
@@ -1,60 +1,60 @@
-VADPT2	;ALB/MJK - ESTABLISH PATIENT VARIABLES ; 3/23/88  9:13 PM ; [10/20/95 4:02pm]
-	;;5.3;Registration;**69,749**;Aug 13, 1993;Build 10
-5	; -- INP call
-	S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="" S VANOW=$$NOW^XLFDT K VAMV,VAMV0
-	I '$D(VAINDT) N VAINDT S VAINDT=VANOW
-	S VATD=9999999.999999-VAINDT
-	F VAID=VATD:0 S VAID=$O(^DGPM("APID",DFN,VAID)) Q:'VAID  S VAMV=$O(^(VAID,0)) D CHK I $D(VAMV) K:"^3^4^5^"[("^"_VAMT_"^") VAMV,VAMV0 Q
-	;
-	G:'$D(VAMV0) DONE
-	S (VAPRT,VAPRC,VACN)=1 D GET^VADPT30
-	S VAMV0=^DGPM(VAMV,0),VAMVT=$P(VAMV0,"^",4),VACA=$P(VAMV0,"^",14),VACA0=$S($D(^DGPM(+VACA,0)):^(0),1:"")
-	;
-	; set: adm ifn(1) ; doctor(2) ; tr spec(3) ; ward(4) ; room(5) ; attending (11)
-	S @VAV@($P(VAS,"^",1))=VACA,@VAV@($P(VAS,"^",2))=VAPP,@VAV@($P(VAS,"^",3))=VATS,@VAV@($P(VAS,"^",4))=VAWD,@VAV@($P(VAS,"^",5))=$P(VARM,"^",2),@VAV@($P(VAS,"^",11))=VAAP
-	;
-	; set bed/no bed  mvt type(6)
-	D IB S @VAV@($P(VAS,"^",6))=VAZ
-	;
-	; set adm date(7)
-	S Y=+VACA0 X:Y ^DD("DD") S @VAV@($P(VAS,"^",7))=+VACA0_"^"_Y
-	;
-	; set: adm type(8) ; adm dx(9) ; ptf ifn(10)
-	S @VAV@($P(VAS,"^",8))=$P(VACA0,"^",4)_"^"_$S($D(^DG(405.1,+$P(VACA0,"^",4),0)):$P(^(0),"^"),1:""),@VAV@($P(VAS,"^",9))=$P(VACA0,"^",10),@VAV@($P(VAS,"^",10))=$P(VACA0,"^",16)
-	;
-DONE	K VAID,VANOW,VACA,VACA0,VAMV,VAMV0,VATD,VAMT,VAMVT D KVAR^VADPT30 Q
-	;
-IB	;In-Bed status
-	; input:  VAINDT = internal date of requested info
-	;         VAMV   = starting IFN
-	;         VAMV0  = 0th of VAMV
-	;
-	; output: VAZ    = <O:not in bed OR 1: in bed>^fac. mvt name
-	;         VAZ(2) = abs ret date
-	;
-	S VAZ=0,VAZ(2)=""
-	S VAXI=+$O(^DGPM("APMV",DFN,+$P(VAMV0,"^",14),9999999.999999-VAINDT)),VAXI=+$O(^(VAXI,0))
-	I 'VAXI,$D(VAIP("L")),$P(VAMV0,"^",2)=4 S VAXI=VAMV ; only used via IN5
-	G IBQ:'VAXI
-	S VAX0=$S($D(^DGPM(VAXI,0)):^(0),1:"")
-	G IBQ:VAX0']"",IBQ:"^3^5^"[("^"_$P(VAX0,"^",2)_"^")
-	S VAXI=$S($D(^DG(405.1,+$P(VAX0,"^",4),0)):$P(^(0),"^"),1:"")
-	; -- check in-bed status flag
-	S VAZ=$S('$D(^DG(405.2,+$P(VAX0,"^",18),"E")):1,1:'^("E"))_"^"_VAXI,VAZ(2)=$P(VAX0,"^",13)
-IBQ	K VAXI,VAX0 Q
-	;
-CHK	; -- check if mvt exists and if 'while asih' type d/c
-	;    if VAMV returned undefined then continue $Oing
-	;
-	I $D(^DGPM(+VAMV,0)) S VAMV0=^(0),VAMT=$P(VAMV0,"^",2)
-	I '$D(VAMV0) K VAMV G CHKQ
-	I "^42^47^"[("^"_$P(VAMV0,"^",18)_"^"),$P(VAMV0,"^",22)'=2,$O(^DGPM("APMV",DFN,+$P(VAMV0,"^",14),VAID)),$O(^($O(^(VAID)),0)),$D(^DGPM($O(^(0)),0)),"^13^44^"[("^"_$P(^(0),"^",18)_"^") K VAMV,VAMV0
-	; info: 47 mvt can not have seq #; will always be null
-CHKQ	Q
-	;
-ADM	; -- send back adm ifn for dfn on vaindt or now
-	S VADT=$S($D(VAINDT):VAINDT,1:"") I 'VADT  S VADT=$$NOW^XLFDT
-	S VAID=9999999.999999-VADT,VADMVT=""
-	F  S VAID=$O(^DGPM("ATID1",DFN,VAID)) Q:'VAID  S VAMV=+$O(^DGPM("ATID1",DFN,VAID,0)) I $D(^DGPM(VAMV,0)) S VAMV0=^(0),VAMV1=$S($D(^DGPM(+$P(VAMV0,"^",17),0)):^(0),1:9999999.999999) D  Q:VADMVT!($P(VAMV0,U,18)'=40)
-	.I VAMV0'>VADT,VAMV1>VADT S VADMVT=VAMV
-	K VAID,VADT,VAMV,VAMV0,VAMV1
+VADPT2 ;ALB/MJK - ESTABLISH PATIENT VARIABLES ; 3/23/88  9:13 PM ; [10/20/95 4:02pm]
+ ;;5.3;Registration;**69**;Aug 13, 1993
+5 ; -- INP call
+ S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="" D NOW^%DTC S VANOW=% K VAMV,VAMV0
+ I '$D(VAINDT) N VAINDT S VAINDT=VANOW
+ S VATD=9999999.999999-VAINDT
+ F VAID=VATD:0 S VAID=$O(^DGPM("APID",DFN,VAID)) Q:'VAID  S VAMV=$O(^(VAID,0)) D CHK I $D(VAMV) K:"^3^4^5^"[("^"_VAMT_"^") VAMV,VAMV0 Q
+ ;
+ G:'$D(VAMV0) DONE
+ S (VAPRT,VAPRC,VACN)=1 D GET^VADPT30
+ S VAMV0=^DGPM(VAMV,0),VAMVT=$P(VAMV0,"^",4),VACA=$P(VAMV0,"^",14),VACA0=$S($D(^DGPM(+VACA,0)):^(0),1:"")
+ ;
+ ; set: adm ifn(1) ; doctor(2) ; tr spec(3) ; ward(4) ; room(5) ; attending (11)
+ S @VAV@($P(VAS,"^",1))=VACA,@VAV@($P(VAS,"^",2))=VAPP,@VAV@($P(VAS,"^",3))=VATS,@VAV@($P(VAS,"^",4))=VAWD,@VAV@($P(VAS,"^",5))=$P(VARM,"^",2),@VAV@($P(VAS,"^",11))=VAAP
+ ;
+ ; set bed/no bed  mvt type(6)
+ D IB S @VAV@($P(VAS,"^",6))=VAZ
+ ;
+ ; set adm date(7)
+ S Y=+VACA0 X:Y ^DD("DD") S @VAV@($P(VAS,"^",7))=+VACA0_"^"_Y
+ ;
+ ; set: adm type(8) ; adm dx(9) ; ptf ifn(10)
+ S @VAV@($P(VAS,"^",8))=$P(VACA0,"^",4)_"^"_$S($D(^DG(405.1,+$P(VACA0,"^",4),0)):$P(^(0),"^"),1:""),@VAV@($P(VAS,"^",9))=$P(VACA0,"^",10),@VAV@($P(VAS,"^",10))=$P(VACA0,"^",16)
+ ;
+DONE K VAID,VANOW,VACA,VACA0,VAMV,VAMV0,VATD,VAMT,VAMVT D KVAR^VADPT30 Q
+ ;
+IB ;In-Bed status
+ ; input:  VAINDT = internal date of requested info
+ ;         VAMV   = starting IFN
+ ;         VAMV0  = 0th of VAMV
+ ;
+ ; output: VAZ    = <O:not in bed OR 1: in bed>^fac. mvt name
+ ;         VAZ(2) = abs ret date
+ ;
+ S VAZ=0,VAZ(2)=""
+ S VAXI=+$O(^DGPM("APMV",DFN,+$P(VAMV0,"^",14),9999999.999999-VAINDT)),VAXI=+$O(^(VAXI,0))
+ I 'VAXI,$D(VAIP("L")),$P(VAMV0,"^",2)=4 S VAXI=VAMV ; only used via IN5
+ G IBQ:'VAXI
+ S VAX0=$S($D(^DGPM(VAXI,0)):^(0),1:"")
+ G IBQ:VAX0']"",IBQ:"^3^5^"[("^"_$P(VAX0,"^",2)_"^")
+ S VAXI=$S($D(^DG(405.1,+$P(VAX0,"^",4),0)):$P(^(0),"^"),1:"")
+ ; -- check in-bed status flag
+ S VAZ=$S('$D(^DG(405.2,+$P(VAX0,"^",18),"E")):1,1:'^("E"))_"^"_VAXI,VAZ(2)=$P(VAX0,"^",13)
+IBQ K VAXI,VAX0 Q
+ ;
+CHK ; -- check if mvt exists and if 'while asih' type d/c
+ ;    if VAMV returned undefined then continue $Oing
+ ;
+ I $D(^DGPM(+VAMV,0)) S VAMV0=^(0),VAMT=$P(VAMV0,"^",2)
+ I '$D(VAMV0) K VAMV G CHKQ
+ I "^42^47^"[("^"_$P(VAMV0,"^",18)_"^"),$P(VAMV0,"^",22)'=2,$O(^DGPM("APMV",DFN,+$P(VAMV0,"^",14),VAID)),$O(^($O(^(VAID)),0)),$D(^DGPM($O(^(0)),0)),"^13^44^"[("^"_$P(^(0),"^",18)_"^") K VAMV,VAMV0
+ ; info: 47 mvt can not have seq #; will always be null
+CHKQ Q
+ ;
+ADM ; -- send back adm ifn for dfn on vaindt or now
+ S VADT=$S($D(VAINDT):VAINDT,1:"") I 'VADT D NOW^%DTC S VADT=%
+ S VAID=9999999.999999-VADT,VADMVT=""
+ F  S VAID=$O(^DGPM("ATID1",DFN,VAID)) Q:'VAID  S VAMV=+$O(^DGPM("ATID1",DFN,VAID,0)) I $D(^DGPM(VAMV,0)) S VAMV0=^(0),VAMV1=$S($D(^DGPM(+$P(VAMV0,"^",17),0)):^(0),1:9999999.999999) D  Q:VADMVT!($P(VAMV0,U,18)'=40)
+ .I VAMV0'>VADT,VAMV1>VADT S VADMVT=VAMV
+ K VAID,VADT,VAMV,VAMV0,VAMV1
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m	(revision 623)
@@ -1,97 +1,97 @@
-VADPT3	;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm
-	;;5.3;Registration;**532,749**;Aug 13, 1993;Build 10
-	;Inpatient variables [Version 5.0 and above]
-6	;
-	S (NOW,VAX("DAT"))=$$NOW^XLFDT,NOWI=9999999.999999-NOW
-	;
-	I $D(VAIP("E")),$D(^DGPM(+VAIP("E"),0)) S VAX("DT")=+^(0),E=+VAIP("E") G GO ;Specific Entry
-	;
-	I $D(VAIP("D")),"^l^L^"[("^"_$E(VAIP("D"))_"^") D LAST G GO:E,Q
-	;
-	S VAX=$S($D(VAIP("D")):VAIP("D"),$D(VAINDT):VAINDT,1:0)
-	I VAX S:VAX?7N!(VAX?7N1".".N) VAX("DT")=VAX I '$D(VAX("DT")) G Q ;Invalid Entry
-	;
-	S:'$D(VAX("DT")) VAX("DT")=NOW
-	I VAX("DT")=VAX("DAT") S E=$S($D(^DPT(DFN,.102)):+^(.102),1:0),E=$S($D(^DGPM(E,0)):E,1:0) G GO:E D LODGER G GO:E D ASIHOF G GO:E,Q ;Current IP
-	;
-	;Find Past Movement
-	S VAX=+$O(^DGPM("APID",DFN,9999999.999999-VAX("DT"))) I 'VAX D LODGER G GO:E,Q
-	S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I '$D(^DGPM(VAX,0)) D LODGER G GO:E,Q
-	S VAZ=^DGPM(VAX,0) D OK G GO:E D LODGER G GO:E,Q
-	;
-GO	S:'$D(VAX("DT")) VAX("DT")=NOW D ^VADPT31 ; setting of VAX("DT") can be removed??
-	;
-Q	K NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("VADPTZ",$J,DFN) D KVAR^VADPT30 Q
-	;
-OK	N VAADT,VADDT,VAQUIT
-	S E=0,VAZ2="^"_(+$P(VAZ,"^",18))_"^"
-	I "^13^41^46^"[VAZ2 D OK1 Q:'VAX  G OK
-	I "^42^"[VAZ2 D 42 I 'Y D OK1 Q:'VAX  G OK
-	I "^47^"[VAZ2 D 47 I 'Y D OK1 Q:'VAX  G OK
-	I $D(VAX("DT")),$P(VAZ,"^",2)=3,VAZ'>VAX("DT") Q
-	;DG*5.3*532
-	;Check for out-of-order disch. recs caused by same day adm./disch.
-	;where disch. date < adm. date because disch. date had no time
-	I +VAZ<2890000,$D(VAX("DT")),$P(VAZ,"^",2)'=3 S VAQUIT=0 D  Q:VAQUIT
-	.S VAADT=$P(VAZ,"^",14) Q:'VAADT
-	.S VADDT=$P($G(^DGPM(VAADT,0)),"^",17) Q:'VADDT
-	.S VADDT=$P($G(^DGPM(VADDT,0)),"^",14) I $P(VADDT,".",2)="",VADDT=$P(VAADT,"."),VAZ'>VAX("DT") S VAQUIT=1
-	S E=+VAX Q
-	;
-OK1	S VAX=+$O(^DGPM("APID",DFN,9999999.9999999-(VAZ+($P(VAZ,"^",22)/10000000)))),VAX=+$O(^(VAX,0))
-	I VAX,$D(^DGPM(VAX,0)) S VAZ=^(0)
-	Q
-	;
-LAST	; returns last movement for patient
-	; called by bed control and pt inquiry
-	S VAX=+$O(^DGPM("APID",DFN,NOWI)),E=0
-	I $D(VAIP("L")) D LLDCHK G LASTQ:E
-	S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I $D(^DGPM(VAX,0)) S VAZ=^(0) D OK
-LASTQ	S VAX("DT")=NOW
-	Q
-	;
-LODGER	;
-	S E=0 G LODGERQ:'$D(VAIP("L"))
-	I VAX("DT")=VAX("DAT") S VAX=$S($D(^DPT(DFN,.107)):^(.107),1:"") G LODGERQ:VAX']"" S E=$S($D(^DPT("LD",VAX,DFN)):+^(DFN),1:0) G LODGERQ
-	;
-	S VAX=$O(^DGPM("ATID4",DFN,9999999.999999-VAX("DT"))) S:VAX E=+$O(^DGPM("ATID4",DFN,VAX,0))
-	I E S E=$S($D(^DGPM(E,0)):E,1:0) I E,$D(^DGPM(+$P(^(0),"^",17),0)),^(0)'>VAX("DT") S E=0
-LODGERQ	Q
-	;
-LLDCHK	; -- last lodger mvt checking ; build array of inverse dates and chk
-	N IDT S IDT(VAX)=0
-	S IDT=+$O(^DGPM("ATID4",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
-	S IDT=+$O(^DGPM("ATID5",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
-	S IDT=+$O(IDT(0)) I IDT S E=IDT(IDT),E=$S($D(^DGPM(E,0)):E,1:0)
-	Q
-	; 
-CHK	;
-	G VAR^VADPT30
-	;
-ASIHOF	; -- is last mvt asih oth fac
-	S E=0,VAX=$S('$O(^DGPM("APID",DFN,NOWI)):"",1:$O(^DGPM("APID",DFN,$O(^(NOWI)),0)))
-	I VAX,$D(^DGPM(VAX,0)),"^43^45^"[("^"_$P(^(0),"^",18)_"^") S E=VAX
-	Q
-	;
-42	; -- check to see if this mvt can be used; for 'while asih' d/c category
-	;   If Y returned high then mvt is good
-	;
-	I VAZ'<VAX("DAT") S Y=0 G Q42 ; not a real d/c yet
-	I $P(VAZ,"^",22)=2 S Y=0 G Q42 ; nhcu d/c assoicated w/asih d/c (seq #2)
-	D SCAN
-Q42	Q
-	;
-SCAN	; -- determine is d/c while in other fac(Y=1 returned if so.)
-	;
-	N VAID,VACA,M S Y=0,VAID=9999999.999999-VAZ,VACA=+$P(VAZ,"^",14)
-	F VAID=VAID:0 S VAID=$O(^DGPM("APMV",DFN,VACA,VAID)) Q:'VAID  I $D(^DGPM(+$O(^(VAID,0)),0)) S M=$P(^(0),"^",18) I "^13^44^43^45^"[("^"_M_"^") S Y=$S(M=43!(M=45):1,1:0) Q
-	Q
-	;
-47	; -- check to see if d/c from nhcu while asih in other fac
-	;   If y returned high then mvt is good.
-	D SCAN Q
-	;
-	; 13 = to asih (vah)     (xfr)|44 = resume asih in parent facility (xfr)
-	; 41 = from asih         (d/c)|45 = change asih location(other fac)(xfr)
-	; 42 = while asih        (d/c)|46 = continues asih (other fac)     (d/c)
-	; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)
+VADPT3 ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm
+ ;;5.3;Registration;**532**;Aug 13, 1993
+ ;Inpatient variables [Version 5.0 and above]
+6 ;
+ D NOW^%DTC S (NOW,VAX("DAT"))=%,NOWI=9999999.999999-%
+ ;
+ I $D(VAIP("E")),$D(^DGPM(+VAIP("E"),0)) S VAX("DT")=+^(0),E=+VAIP("E") G GO ;Specific Entry
+ ;
+ I $D(VAIP("D")),"^l^L^"[("^"_$E(VAIP("D"))_"^") D LAST G GO:E,Q
+ ;
+ S VAX=$S($D(VAIP("D")):VAIP("D"),$D(VAINDT):VAINDT,1:0)
+ I VAX S:VAX?7N!(VAX?7N1".".N) VAX("DT")=VAX I '$D(VAX("DT")) G Q ;Invalid Entry
+ ;
+ S:'$D(VAX("DT")) VAX("DT")=NOW
+ I VAX("DT")=VAX("DAT") S E=$S($D(^DPT(DFN,.102)):+^(.102),1:0),E=$S($D(^DGPM(E,0)):E,1:0) G GO:E D LODGER G GO:E D ASIHOF G GO:E,Q ;Current IP
+ ;
+ ;Find Past Movement
+ S VAX=+$O(^DGPM("APID",DFN,9999999.999999-VAX("DT"))) I 'VAX D LODGER G GO:E,Q
+ S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I '$D(^DGPM(VAX,0)) D LODGER G GO:E,Q
+ S VAZ=^DGPM(VAX,0) D OK G GO:E D LODGER G GO:E,Q
+ ;
+GO S:'$D(VAX("DT")) VAX("DT")=NOW D ^VADPT31 ; setting of VAX("DT") can be removed??
+ ;
+Q K NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY("VADPTZ",$J,DFN) D KVAR^VADPT30 Q
+ ;
+OK N VAADT,VADDT,VAQUIT
+ S E=0,VAZ2="^"_(+$P(VAZ,"^",18))_"^"
+ I "^13^41^46^"[VAZ2 D OK1 Q:'VAX  G OK
+ I "^42^"[VAZ2 D 42 I 'Y D OK1 Q:'VAX  G OK
+ I "^47^"[VAZ2 D 47 I 'Y D OK1 Q:'VAX  G OK
+ I $D(VAX("DT")),$P(VAZ,"^",2)=3,VAZ'>VAX("DT") Q
+ ;DG*5.3*532
+ ;Check for out-of-order disch. recs caused by same day adm./disch.
+ ;where disch. date < adm. date because disch. date had no time
+ I +VAZ<2890000,$D(VAX("DT")),$P(VAZ,"^",2)'=3 S VAQUIT=0 D  Q:VAQUIT
+ .S VAADT=$P(VAZ,"^",14) Q:'VAADT
+ .S VADDT=$P($G(^DGPM(VAADT,0)),"^",17) Q:'VADDT
+ .S VADDT=$P($G(^DGPM(VADDT,0)),"^",14) I $P(VADDT,".",2)="",VADDT=$P(VAADT,"."),VAZ'>VAX("DT") S VAQUIT=1
+ S E=+VAX Q
+ ;
+OK1 S VAX=+$O(^DGPM("APID",DFN,9999999.9999999-(VAZ+($P(VAZ,"^",22)/10000000)))),VAX=+$O(^(VAX,0))
+ I VAX,$D(^DGPM(VAX,0)) S VAZ=^(0)
+ Q
+ ;
+LAST ; returns last movement for patient
+ ; called by bed control and pt inquiry
+ S VAX=+$O(^DGPM("APID",DFN,NOWI)),E=0
+ I $D(VAIP("L")) D LLDCHK G LASTQ:E
+ S VAX=+$O(^DGPM("APID",DFN,VAX,0)) I $D(^DGPM(VAX,0)) S VAZ=^(0) D OK
+LASTQ S VAX("DT")=NOW
+ Q
+ ;
+LODGER ;
+ S E=0 G LODGERQ:'$D(VAIP("L"))
+ I VAX("DT")=VAX("DAT") S VAX=$S($D(^DPT(DFN,.107)):^(.107),1:"") G LODGERQ:VAX']"" S E=$S($D(^DPT("LD",VAX,DFN)):+^(DFN),1:0) G LODGERQ
+ ;
+ S VAX=$O(^DGPM("ATID4",DFN,9999999.999999-VAX("DT"))) S:VAX E=+$O(^DGPM("ATID4",DFN,VAX,0))
+ I E S E=$S($D(^DGPM(E,0)):E,1:0) I E,$D(^DGPM(+$P(^(0),"^",17),0)),^(0)'>VAX("DT") S E=0
+LODGERQ Q
+ ;
+LLDCHK ; -- last lodger mvt checking ; build array of inverse dates and chk
+ N IDT S IDT(VAX)=0
+ S IDT=+$O(^DGPM("ATID4",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
+ S IDT=+$O(^DGPM("ATID5",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))
+ S IDT=+$O(IDT(0)) I IDT S E=IDT(IDT),E=$S($D(^DGPM(E,0)):E,1:0)
+ Q
+ ; 
+CHK ;
+ G VAR^VADPT30
+ ;
+ASIHOF ; -- is last mvt asih oth fac
+ S E=0,VAX=$S('$O(^DGPM("APID",DFN,NOWI)):"",1:$O(^DGPM("APID",DFN,$O(^(NOWI)),0)))
+ I VAX,$D(^DGPM(VAX,0)),"^43^45^"[("^"_$P(^(0),"^",18)_"^") S E=VAX
+ Q
+ ;
+42 ; -- check to see if this mvt can be used; for 'while asih' d/c category
+ ;   If Y returned high then mvt is good
+ ;
+ I VAZ'<VAX("DAT") S Y=0 G Q42 ; not a real d/c yet
+ I $P(VAZ,"^",22)=2 S Y=0 G Q42 ; nhcu d/c assoicated w/asih d/c (seq #2)
+ D SCAN
+Q42 Q
+ ;
+SCAN ; -- determine is d/c while in other fac(Y=1 returned if so.)
+ ;
+ N VAID,VACA,M S Y=0,VAID=9999999.999999-VAZ,VACA=+$P(VAZ,"^",14)
+ F VAID=VAID:0 S VAID=$O(^DGPM("APMV",DFN,VACA,VAID)) Q:'VAID  I $D(^DGPM(+$O(^(VAID,0)),0)) S M=$P(^(0),"^",18) I "^13^44^43^45^"[("^"_M_"^") S Y=$S(M=43!(M=45):1,1:0) Q
+ Q
+ ;
+47 ; -- check to see if d/c from nhcu while asih in other fac
+ ;   If y returned high then mvt is good.
+ D SCAN Q
+ ;
+ ; 13 = to asih (vah)     (xfr)|44 = resume asih in parent facility (xfr)
+ ; 41 = from asih         (d/c)|45 = change asih location(other fac)(xfr)
+ ; 42 = while asih        (d/c)|46 = continues asih (other fac)     (d/c)
+ ; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT5.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT5.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT5.m	(revision 623)
@@ -1,103 +1,103 @@
-VADPT5	;ALB/MRL/MJK - PATIENT VARIABLES [REG]; 14 DEC 1988 ; 8/6/04 7:42am
-	;;5.3;Registration;**54,63,242,584,749**;Aug 13, 1993;Build 10
-10	;Registration/Disposition [REG]
-	N VARPSV
-	S VARPSV("C")=$S('$G(VARP("C")):999999999,1:+VARP("C"))
-	S VARPSV("F")=9999999-$S($G(VARP("F"))?7N.E:VARP("F"),1:0)
-	S VARPSV("T")=$S($G(VARP("T"))?7N.E:VARP("T"),1:7777777) I '$P(VARPSV("T"),".",2) S $P(VARPSV("T"),".",2)=999999
-	S VARPSV("T")=9999999-VARPSV("T")
-	S VAX=VARPSV("T"),VAX(1)=0
-	I '$D(^DPT(DFN,"DIS")) Q
-	F I=0:0 S VAX=$O(^DPT(DFN,"DIS",VAX)) Q:VAX=""!(VAX>VARPSV("F"))!(VAX(1)+1>VARPSV("C"))  S VAX(2)=$G(^DPT(DFN,"DIS",VAX,0)),VAX(1)=VAX(1)+1 D 101:+VAX(2)>0
-	Q
-101	S (VAX("I"),VAX("E"))="",VAX(3)=0 F I=1,2,3,4,5,6,7,9 S VAX(3)=VAX(3)+1,$P(VAX("I"),"^",VAX(3))=$P(VAX(2),"^",I) D 102
-	S @VAV@(VAX(1),"I")=VAX("I"),@VAV@(VAX(1),"E")=VAX("E") Q
-102	I "^1^6^"[("^"_VAX(3)_"^") S Y=$P(VAX("I"),"^",VAX(3)) I Y]"" X ^DD("DD") S $P(VAX("E"),"^",VAX(3))=Y Q
-	S X(1)=$S($D(^DD(2.101,$S(I<9:(I-1),1:I),0)):$P(^(0),"^",3),1:"") I "^2^3^"[("^"_VAX(3)_"^"),$P(VAX("I"),"^",VAX(3))]"",X(1)]"" S $P(VAX("E"),"^",VAX(3))=$P($P(X(1),$P(VAX("I"),"^",VAX(3))_":",2),";",1) Q
-	I "^4^5^7^8^"[("^"_VAX(3)_"^"),$P(VAX("I"),"^",VAX(3))]"",X(1)]"" S X(1)="^"_X(1)_$P(VAX("I"),"^",VAX(3))_",0)" I $D(@(X(1))) S $P(VAX("E"),"^",VAX(3))=$P(^(0),"^",1)
-	Q
-	;
-11	;Clinic Enrollments [SDE]
-	S (VAX,VAX(1))=0 F I=0:0 S VAX=$O(^DPT(DFN,"DE",VAX)) Q:VAX'>0  S VAZ=$S($D(^DPT(DFN,"DE",VAX,0)):^(0),1:"") I +VAZ,$P(VAZ,"^",2)'="I" S VAX(3)=0 D 111
-	Q
-111	S VAX(4)=0 F I1=0:0 S VAX(4)=$O(^DPT(DFN,"DE",VAX,1,VAX(4))) Q:VAX(4)'>0!(VAX(3))  S VAZ(1)=$S($D(^DPT(DFN,"DE",VAX,1,VAX(4),0)):^(0),1:"") I +VAZ(1),$P(VAZ(1),"^",3)']"" S VAX(3)=VAZ(1)
-	Q:'VAX(3)  S (VAX("I"),VAX("E"))="",Y=+VAX(3),$P(VAX("I"),"^",2)=Y X ^DD("DD") S $P(VAX("E"),"^",2)=Y
-	S $P(VAX("I"),"^",3)=$P(VAX(3),"^",2) I $P(VAX("I"),"^",3)]"" S $P(VAX("E"),"^",3)=$S($P(VAX("I"),"^",3)="O":"OPT",$P(VAX("I"),"^",3)="A":"AC",1:"")
-	S $P(VAX("I"),"^",1)=+VAZ,$P(VAX("E"),"^",1)=$S($D(^SC(+VAZ,0)):$P(^(0),"^",1),1:""),VAX(1)=VAX(1)+1,@VAV@(VAX(1),"I")=VAX("I"),@VAV@(VAX(1),"E")=VAX("E") Q
-	;
-12	;Appointments [SDA]
-	N VASDSV,SDCNT,SDARRAY,VANOW
-	S VANOW=$$NOW^XLFDT
-	S VASDSV("F")=$S($G(VASD("F"))?7N.E:VASD("F"),1:VANOW)
-	S VASDSV("T")=$S(+$G(VASD("T")):+VASD("T"),1:9999999) I '$P(VASDSV("T"),".",2) S $P(VASDSV("T"),".",2)=999999
-	S VASDSV("W")=$S('$G(VASD("W")):12,1:VASD("W"))
-	S VAZ(2)=$S($D(VASD("N")):VASD("N"),1:9999)
-	;Set STATUS Codes (VistA;RSA)
-	S VAZ=";R^I;I^N;NS^NA;NSR^C;CC^CA;CCR^PC;CP^PCA;CPR^NT;NT^",VAZ(1)=""
-	;Extract User Required STATUS Codes in RSA format
-	F I=1:1 S I1=+$E(VASDSV("W"),I) Q:'I1  D
-	.S VAZ(1)=VAZ(1)_$P($P(VAZ,"^",I1),";",2)_";"
-	;Create parameter list for the extrinsic call to the Appointment API
-	;Note: Appointment API can only accept a maximum of 3 fields 
-	;               to filter on.
-	; 1 : "FROM;TO" Appointment Date Range to Search
-	; 2 : Clinic IEN or Array of Clinic IENs if defined (Pass the Root)
-	; 3 : Requested STATUS Codes (Passed if VASD("C") is not defined.)
-	; 4 : Patient IEN
-	S SDARRAY="",SDARRAY(1)=VASDSV("F")_";"_VASDSV("T")
-	I $O(VASD("C",0))>0 S SDARRAY(2)="VASD(""C"","
-	E  S SDARRAY(3)=VAZ(1)
-	S SDARRAY(4)=DFN
-	;Set Fields for API to Return
-	;  1 : Appointment Date/Time
-	;  2 : Clinic
-	;  3 : Appointment Status
-	; 10 : Appointment Type
-	S SDARRAY("FLDS")="1;2;3;10"
-	;Remove Clinic IEN from Global Reference
-	S SDARRAY("SORT")="P"
-	;Call Appointment API (Pass Array by reference)
-	S SDCNT=$$SDAPI^SDAMA301(.SDARRAY)
-	S VAX="",VAX(1)=0
-	;If error returned, determine error and set VAERR appropriately
-	; 1 : For any error other than 101
-	; 2 : If error is 101 : Database is unavailable  
-	I SDCNT<0 S VAX=$O(^TMP($J,"SDAMA301",VAX)) S VAERR=$S(VAX=101:2,1:1) K ^TMP($J,"SDAMA301") Q
-	D 122:SDCNT>0
-	Q
-121	S VAX(5)=1 I VASDSV("W")'[1,$P(VAZ,"^",2)']"" S VAX(5)=0 Q
-	I VASDSV("C"),'$D(VASD("C",+VAZ)) S VAX(5)=0 Q
-	S (VAX("I"),VAX("E"))="",VAX(2)=1,$P(VAX("I"),"^",1)=+VAX F I1=1,2,16 S VAX(2)=VAX(2)+1,$P(VAX("I"),"^",VAX(2))=$P(VAZ,"^",I1)
-	Q
-122	;Build Internal/External Output Globals
-	;
-	N SDCIEN,SDDTM,SDNODE
-	S (SDCIEN,SDDTM)=""
-	;Redefine VAZ (STATUS Codes(RSA;VistA))
-	S VAZ="R;^I;I^NS;N^NSR;NA^CC;C^CCR;CA^CP;PC^CPR;PCA^NT;NT^"
-	S SDDTM=""
-	;Loop through appointments and convert for output
-	F  S SDDTM=$O(^TMP($J,"SDAMA301",DFN,SDDTM)) Q:'SDDTM  D 
-	.;Get Appointment Information and clear VAX("I") & VAX("E")
-	.S SDNODE=^(SDDTM),(VAX("I"),VAX("E"))=""
-	.;If Clinics were passed to appointment API,
-	.;     Filter on Appointment Status Codes
-	.I $O(VASD("C",0))>0,(VAZ(1)'[($P($P(SDNODE,"^",3),";")_";")) Q
-	.;Extract and format Appointment Date/Time
-	.S Y=$P(SDNODE,"^",1)
-	.S $P(VAX("I"),"^",1)=Y
-	.X ^DD("DD") S $P(VAX("E"),"^",1)=Y
-	.;Extract and format Clinic Information
-	.S $P(VAX("I"),"^",2)=$P($P(SDNODE,"^",2),";",1)
-	.S $P(VAX("E"),"^",2)=$P($P(SDNODE,"^",2),";",2)
-	.;Extract and format Appointment Type
-	.S $P(VAX("I"),"^",4)=$P($P(SDNODE,"^",10),";",1)
-	.S $P(VAX("E"),"^",4)=$P($P(SDNODE,"^",10),";",2)
-	.;Extract and format Appointment Status
-	.S Y=$P($P(VAZ,$P($P(SDNODE,"^",3),";")_";",2),"^"),$P(VAX("I"),"^",3)=Y
-	.I Y]"" S X=$S($D(^DD(2.98,3,0)):$P(^(0),"^",3),1:""),$P(VAX("E"),"^",3)=$P($P(X,Y_":",2),";",1)
-	.S VAX(1)=VAX(1)+1
-	.;Store information in global
-	.S @VAV@(VAX(1),"I")=VAX("I"),@VAV@(VAX(1),"E")=VAX("E")
-	K ^TMP($J,"SDAMA301")
-	Q
+VADPT5 ;ALB/MRL/MJK - PATIENT VARIABLES [REG]; 14 DEC 1988 ; 8/6/04 7:42am
+ ;;5.3;Registration;**54,63,242,584**;Aug 13, 1993
+10 ;Registration/Disposition [REG]
+ N VARPSV
+ S VARPSV("C")=$S('$G(VARP("C")):999999999,1:+VARP("C"))
+ S VARPSV("F")=9999999-$S($G(VARP("F"))?7N.E:VARP("F"),1:0)
+ S VARPSV("T")=$S($G(VARP("T"))?7N.E:VARP("T"),1:7777777) I '$P(VARPSV("T"),".",2) S $P(VARPSV("T"),".",2)=999999
+ S VARPSV("T")=9999999-VARPSV("T")
+ S VAX=VARPSV("T"),VAX(1)=0
+ I '$D(^DPT(DFN,"DIS")) Q
+ F I=0:0 S VAX=$O(^DPT(DFN,"DIS",VAX)) Q:VAX=""!(VAX>VARPSV("F"))!(VAX(1)+1>VARPSV("C"))  S VAX(2)=$G(^DPT(DFN,"DIS",VAX,0)),VAX(1)=VAX(1)+1 D 101:+VAX(2)>0
+ Q
+101 S (VAX("I"),VAX("E"))="",VAX(3)=0 F I=1,2,3,4,5,6,7,9 S VAX(3)=VAX(3)+1,$P(VAX("I"),"^",VAX(3))=$P(VAX(2),"^",I) D 102
+ S @VAV@(VAX(1),"I")=VAX("I"),@VAV@(VAX(1),"E")=VAX("E") Q
+102 I "^1^6^"[("^"_VAX(3)_"^") S Y=$P(VAX("I"),"^",VAX(3)) I Y]"" X ^DD("DD") S $P(VAX("E"),"^",VAX(3))=Y Q
+ S X(1)=$S($D(^DD(2.101,$S(I<9:(I-1),1:I),0)):$P(^(0),"^",3),1:"") I "^2^3^"[("^"_VAX(3)_"^"),$P(VAX("I"),"^",VAX(3))]"",X(1)]"" S $P(VAX("E"),"^",VAX(3))=$P($P(X(1),$P(VAX("I"),"^",VAX(3))_":",2),";",1) Q
+ I "^4^5^7^8^"[("^"_VAX(3)_"^"),$P(VAX("I"),"^",VAX(3))]"",X(1)]"" S X(1)="^"_X(1)_$P(VAX("I"),"^",VAX(3))_",0)" I $D(@(X(1))) S $P(VAX("E"),"^",VAX(3))=$P(^(0),"^",1)
+ Q
+ ;
+11 ;Clinic Enrollments [SDE]
+ S (VAX,VAX(1))=0 F I=0:0 S VAX=$O(^DPT(DFN,"DE",VAX)) Q:VAX'>0  S VAZ=$S($D(^DPT(DFN,"DE",VAX,0)):^(0),1:"") I +VAZ,$P(VAZ,"^",2)'="I" S VAX(3)=0 D 111
+ Q
+111 S VAX(4)=0 F I1=0:0 S VAX(4)=$O(^DPT(DFN,"DE",VAX,1,VAX(4))) Q:VAX(4)'>0!(VAX(3))  S VAZ(1)=$S($D(^DPT(DFN,"DE",VAX,1,VAX(4),0)):^(0),1:"") I +VAZ(1),$P(VAZ(1),"^",3)']"" S VAX(3)=VAZ(1)
+ Q:'VAX(3)  S (VAX("I"),VAX("E"))="",Y=+VAX(3),$P(VAX("I"),"^",2)=Y X ^DD("DD") S $P(VAX("E"),"^",2)=Y
+ S $P(VAX("I"),"^",3)=$P(VAX(3),"^",2) I $P(VAX("I"),"^",3)]"" S $P(VAX("E"),"^",3)=$S($P(VAX("I"),"^",3)="O":"OPT",$P(VAX("I"),"^",3)="A":"AC",1:"")
+ S $P(VAX("I"),"^",1)=+VAZ,$P(VAX("E"),"^",1)=$S($D(^SC(+VAZ,0)):$P(^(0),"^",1),1:""),VAX(1)=VAX(1)+1,@VAV@(VAX(1),"I")=VAX("I"),@VAV@(VAX(1),"E")=VAX("E") Q
+ ;
+12 ;Appointments [SDA]
+ N VASDSV,SDCNT,SDARRAY
+ D NOW^%DTC
+ S VASDSV("F")=$S($G(VASD("F"))?7N.E:VASD("F"),1:%)
+ S VASDSV("T")=$S(+$G(VASD("T")):+VASD("T"),1:9999999) I '$P(VASDSV("T"),".",2) S $P(VASDSV("T"),".",2)=999999
+ S VASDSV("W")=$S('$G(VASD("W")):12,1:VASD("W"))
+ S VAZ(2)=$S($D(VASD("N")):VASD("N"),1:9999)
+ ;Set STATUS Codes (VistA;RSA)
+ S VAZ=";R^I;I^N;NS^NA;NSR^C;CC^CA;CCR^PC;CP^PCA;CPR^NT;NT^",VAZ(1)=""
+ ;Extract User Required STATUS Codes in RSA format
+ F I=1:1 S I1=+$E(VASDSV("W"),I) Q:'I1  D
+ .S VAZ(1)=VAZ(1)_$P($P(VAZ,"^",I1),";",2)_";"
+ ;Create parameter list for the extrinsic call to the Appointment API
+ ;Note: Appointment API can only accept a maximum of 3 fields 
+ ;               to filter on.
+ ; 1 : "FROM;TO" Appointment Date Range to Search
+ ; 2 : Clinic IEN or Array of Clinic IENs if defined (Pass the Root)
+ ; 3 : Requested STATUS Codes (Passed if VASD("C") is not defined.)
+ ; 4 : Patient IEN
+ S SDARRAY="",SDARRAY(1)=VASDSV("F")_";"_VASDSV("T")
+ I $O(VASD("C",0))>0 S SDARRAY(2)="VASD(""C"","
+ E  S SDARRAY(3)=VAZ(1)
+ S SDARRAY(4)=DFN
+ ;Set Fields for API to Return
+ ;  1 : Appointment Date/Time
+ ;  2 : Clinic
+ ;  3 : Appointment Status
+ ; 10 : Appointment Type
+ S SDARRAY("FLDS")="1;2;3;10"
+ ;Remove Clinic IEN from Global Reference
+ S SDARRAY("SORT")="P"
+ ;Call Appointment API (Pass Array by reference)
+ S SDCNT=$$SDAPI^SDAMA301(.SDARRAY)
+ S VAX="",VAX(1)=0
+ ;If error returned, determine error and set VAERR appropriately
+ ; 1 : For any error other than 101
+ ; 2 : If error is 101 : Database is unavailable  
+ I SDCNT<0 S VAX=$O(^TMP($J,"SDAMA301",VAX)) S VAERR=$S(VAX=101:2,1:1) K ^TMP($J,"SDAMA301") Q
+ D 122:SDCNT>0
+ Q
+121 S VAX(5)=1 I VASDSV("W")'[1,$P(VAZ,"^",2)']"" S VAX(5)=0 Q
+ I VASDSV("C"),'$D(VASD("C",+VAZ)) S VAX(5)=0 Q
+ S (VAX("I"),VAX("E"))="",VAX(2)=1,$P(VAX("I"),"^",1)=+VAX F I1=1,2,16 S VAX(2)=VAX(2)+1,$P(VAX("I"),"^",VAX(2))=$P(VAZ,"^",I1)
+ Q
+122 ;Build Internal/External Output Globals
+ ;
+ N SDCIEN,SDDTM,SDNODE
+ S (SDCIEN,SDDTM)=""
+ ;Redefine VAZ (STATUS Codes(RSA;VistA))
+ S VAZ="R;^I;I^NS;N^NSR;NA^CC;C^CCR;CA^CP;PC^CPR;PCA^NT;NT^"
+ S SDDTM=""
+ ;Loop through appointments and convert for output
+ F  S SDDTM=$O(^TMP($J,"SDAMA301",DFN,SDDTM)) Q:'SDDTM  D 
+ .;Get Appointment Information and clear VAX("I") & VAX("E")
+ .S SDNODE=^(SDDTM),(VAX("I"),VAX("E"))=""
+ .;If Clinics were passed to appointment API,
+ .;     Filter on Appointment Status Codes
+ .I $O(VASD("C",0))>0,(VAZ(1)'[($P($P(SDNODE,"^",3),";")_";")) Q
+ .;Extract and format Appointment Date/Time
+ .S Y=$P(SDNODE,"^",1)
+ .S $P(VAX("I"),"^",1)=Y
+ .X ^DD("DD") S $P(VAX("E"),"^",1)=Y
+ .;Extract and format Clinic Information
+ .S $P(VAX("I"),"^",2)=$P($P(SDNODE,"^",2),";",1)
+ .S $P(VAX("E"),"^",2)=$P($P(SDNODE,"^",2),";",2)
+ .;Extract and format Appointment Type
+ .S $P(VAX("I"),"^",4)=$P($P(SDNODE,"^",10),";",1)
+ .S $P(VAX("E"),"^",4)=$P($P(SDNODE,"^",10),";",2)
+ .;Extract and format Appointment Status
+ .S Y=$P($P(VAZ,$P($P(SDNODE,"^",3),";")_";",2),"^"),$P(VAX("I"),"^",3)=Y
+ .I Y]"" S X=$S($D(^DD(2.98,3,0)):$P(^(0),"^",3),1:""),$P(VAX("E"),"^",3)=$P($P(X,Y_":",2),";",1)
+ .S VAX(1)=VAX(1)+1
+ .;Store information in global
+ .S @VAV@(VAX(1),"I")=VAX("I"),@VAV@(VAX(1),"E")=VAX("E")
+ K ^TMP($J,"SDAMA301")
+ Q
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m	(revision 623)
@@ -1,60 +1,60 @@
-VADPT61	;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
-	;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
-	;
-1	;;ID Format Enter/Edit
-	W ! S DIC="^DIC(8.2,",DIC(0)="AELMQ" D ^DIC K DIC G Q1:+Y<1
-	S DA=+Y,DIE="^DIC(8.2,",DR="[DG ID FORMAT ENTER/EDIT]" D ^DIE G 1
-Q1	K DIE,DR,DA,Y Q
-	;
-2	;;Eligibility Code Enter/Edit
-	W ! S DIC="^DIC(8,",DIC(0)="AELMQ",DIC("DR")=8 D ^DIC K DIC G Q2:+Y<1
-	S DA=+Y,DIE="^DIC(8,",DR="[DG ELIG ENTER/EDIT]" D ^DIE G 2
-Q2	K DIE,DR,DA,Y
-	Q
-	;
-ASK	;
-	Q:$S('$D(^DIC(8.2,+$P(^DIC(8,VAELG,0),U,10),0)):1,1:'$P(^(0),U,2))
-	W !!,*7,"User Input Needed for '",$P(^DIC(8,VAELG,0),U),"' id:"
-	S DIE="^DPT("_DFN_",""E"",",DR=.03,DA(1)=DFN,DA=VAELG D ^DIE
-	W !!?5,"...",$P(^DIC(8,VAELG,0),U)
-	K DIE,DR,DA,Y
-	Q
-	;
-WARN	; -- interaction warning
-	I $P(X,U,2) W !!?5,*7,"WARNING: User interaction usually is required for this format."
-	Q
-	;
-BEG	;
-	S VASTART=$$NOW^XLFDT
-	Q
-	;
-END	;
-	S VAEND=$$NOW^XLFDT,L=0
-	K XMY
-	S XMSUB=$P($T(OPTS+VAOPT),";",4),XMDUZ=.5,XMTEXT="VATEXT(",XMY(DUZ)=""
-	I VAOPT=3 S XMSUB=XMSUB_" (Format: "_$S($D(^DIC(8.2,VAFMT,0)):$P(^(0),U),1:"UNKNOWN")_")"
-	I VAOPT=5 S XMSUB=XMSUB_" (Eligibility: "_$S($D(^DIC(8,VAELG,0)):$P(^(0),U),1:"UNKNOWN")_")"
-	S L=L+1 S VATEXT(L,0)=" "
-	S Y=VASTART,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job started   at "_Y
-	S Y=VAEND,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job completed at "_Y
-	D ^XMD
-	K VAOPT,VASTART,VAEND,L,VATEXT,XMY,XMSUB,XMDUZ,XMTEXT,Y,% Q
-	;
-TASK	;
-	W !!?5,"The resetting of ID formats can take many hours."
-	W !?5,"It is suggested that it be run at off-peak hours,"
-	W !?5,"perferably over a weekend.",!
-	K ZTSK S X=$T(OPTS+VAOPT),VARS=$P(X,";",5)
-	F I=1:1 S Y=$P(VARS,"^",I) Q:Y=""  S ZTSAVE(Y)=""
-	S ZTSAVE("VAOPT")="",ZTRTN="QUE"_VAOPT_"^VADPT60",ZTDESC=$P(X,";",4),ZTIO="" D ^%ZTLOAD
-	I $D(ZTSK) W !!,"Job has been queued. (Task #",ZTSK,")",!,"A MailMan message will be sent to you when the job has completed."
-TASKQ	K ZTIO,ZTRTN,ZTDESC,ZTSAVE,VARS,Y,X,ZTSK Q
-	;
-OPTS	; -- queue task list ;;opt#;description;vars to save
-	;;1;none
-	;;2;none
-	;;3;Reset ID Format;VAFMT
-	;;4;Reset Primary Eligibilty ID Format
-	;;5;Reset Specific Eligibilty ID Format;VAELG
-	;;6;none
-	;;7;Reset All ID Formats for all Patients
+VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
+ ;;5.3;Registration;;Aug 13, 1993
+ ;
+1 ;;ID Format Enter/Edit
+ W ! S DIC="^DIC(8.2,",DIC(0)="AELMQ" D ^DIC K DIC G Q1:+Y<1
+ S DA=+Y,DIE="^DIC(8.2,",DR="[DG ID FORMAT ENTER/EDIT]" D ^DIE G 1
+Q1 K DIE,DR,DA,Y Q
+ ;
+2 ;;Eligibility Code Enter/Edit
+ W ! S DIC="^DIC(8,",DIC(0)="AELMQ",DIC("DR")=8 D ^DIC K DIC G Q2:+Y<1
+ S DA=+Y,DIE="^DIC(8,",DR="[DG ELIG ENTER/EDIT]" D ^DIE G 2
+Q2 K DIE,DR,DA,Y
+ Q
+ ;
+ASK ;
+ Q:$S('$D(^DIC(8.2,+$P(^DIC(8,VAELG,0),U,10),0)):1,1:'$P(^(0),U,2))
+ W !!,*7,"User Input Needed for '",$P(^DIC(8,VAELG,0),U),"' id:"
+ S DIE="^DPT("_DFN_",""E"",",DR=.03,DA(1)=DFN,DA=VAELG D ^DIE
+ W !!?5,"...",$P(^DIC(8,VAELG,0),U)
+ K DIE,DR,DA,Y
+ Q
+ ;
+WARN ; -- interaction warning
+ I $P(X,U,2) W !!?5,*7,"WARNING: User interaction usually is required for this format."
+ Q
+ ;
+BEG ;
+ D NOW^%DTC S VASTART=%
+ Q
+ ;
+END ;
+ D NOW^%DTC S VAEND=%,L=0
+ K XMY
+ S XMSUB=$P($T(OPTS+VAOPT),";",4),XMDUZ=.5,XMTEXT="VATEXT(",XMY(DUZ)=""
+ I VAOPT=3 S XMSUB=XMSUB_" (Format: "_$S($D(^DIC(8.2,VAFMT,0)):$P(^(0),U),1:"UNKNOWN")_")"
+ I VAOPT=5 S XMSUB=XMSUB_" (Eligibility: "_$S($D(^DIC(8,VAELG,0)):$P(^(0),U),1:"UNKNOWN")_")"
+ S L=L+1 S VATEXT(L,0)=" "
+ S Y=VASTART,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job started   at "_Y
+ S Y=VAEND,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job completed at "_Y
+ D ^XMD
+ K VAOPT,VASTART,VAEND,L,VATEXT,XMY,XMSUB,XMDUZ,XMTEXT,Y,% Q
+ ;
+TASK ;
+ W !!?5,"The resetting of ID formats can take many hours."
+ W !?5,"It is suggested that it be run at off-peak hours,"
+ W !?5,"perferably over a weekend.",!
+ K ZTSK S X=$T(OPTS+VAOPT),VARS=$P(X,";",5)
+ F I=1:1 S Y=$P(VARS,"^",I) Q:Y=""  S ZTSAVE(Y)=""
+ S ZTSAVE("VAOPT")="",ZTRTN="QUE"_VAOPT_"^VADPT60",ZTDESC=$P(X,";",4),ZTIO="" D ^%ZTLOAD
+ I $D(ZTSK) W !!,"Job has been queued. (Task #",ZTSK,")",!,"A MailMan message will be sent to you when the job has completed."
+TASKQ K ZTIO,ZTRTN,ZTDESC,ZTSAVE,VARS,Y,X,ZTSK Q
+ ;
+OPTS ; -- queue task list ;;opt#;description;vars to save
+ ;;1;none
+ ;;2;none
+ ;;3;Reset ID Format;VAFMT
+ ;;4;Reset Primary Eligibilty ID Format
+ ;;5;Reset Specific Eligibilty ID Format;VAELG
+ ;;6;none
+ ;;7;Reset All ID Formats for all Patients
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID.m	(revision 623)
@@ -1,123 +1,121 @@
-VAFCPID	;ALB/MLI,PKE-Create generic PID segment ; 21 Nov 2002  3:13 PM
-	;;5.3;Registration;**91,149,190,415,508,749**;Aug 13, 1993;Build 10
-	;
-	; This routine returns the HL7 defined PID segment with its
-	; mappings to DHCP PATIENT file fields.
-	;
-EN(DFN,VAFSTR,VAFNUM)	; returns PID segment
-	;  Input - DFN as internal entry number of the PATIENT file
-	;          VAFSTR as string of fields requested separated by commas
-	;          VAFNUM as sequential number for SET ID (default=1)
-	;
-	;      ****Also assumes all HL7 variables returned from****
-	;          INIT^HLTRANS are defined
-	;
-	; Output - String containing the desired components of the PID segment
-	;          VAFPID(n) - if the string is longer than 245, the remaining
-	;                      characters will be returned in VAFPID(n) where
-	;                      n is a sequential number beginning with 1
-	;
-	; WARNING: This routine makes external calls to VADPT.  Non-namespaced
-	;          variables may be altered.
-	;
-	N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA ; calls VADPT...have to NEW
-	S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
-	S DFN=$G(DFN)
-	I DFN']"" G QUIT
-	;Get demographics and permanent address
-	S VAPA("P")="" D 4^VADPT
-	S VAFSTR=","_VAFSTR_","
-	K VAFY
-	;Set ID (#1)
-	I VAFSTR[",1," S VAFY(1)=$S($G(VAFNUM):VAFNUM,1:1)
-	;External ID (#2 - always included)
-	S X=$$GETICN^MPIF001(DFN) S:(+X=-1) X="" S VAFY(2)=$S(X]"":X,1:HLQ)
-	;Patient ID (#3 - req)
-	S VAFY(3)=$$M10^HLFNC(DFN)
-	;Alternate ID (#4)
-	I VAFSTR[",4," S X=$G(VA("BID")),VAFY(4)=$S(X]"":X,1:HLQ)
-	;Name (#5 - req)
-	S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
-	S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
-	;Mother's maiden name (#6)
-	I VAFSTR[",6," D
-	.S DGMMN("FILE")=2,DGMMN("IENS")=DFN,DGMMN("FIELD")=.2403
-	.S X=$$HLNAME^XLFNAME(.DGMMN,"",$E(HLECH)),VAFY(6)=$S(X]"":X,1:HLQ)
-	;Date of birth (#7)
-	I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
-	;Sex (#8)
-	I VAFSTR[",8," S X=$P(VADM(5),"^",1),VAFY(8)=$S("^M^F^"[("^"_X_"^"):X,1:"U")
-	;Race (#10)
-	I VAFSTR[10 D
-	.N HOW
-	.S Y=$F(VAFSTR,"10")
-	.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
-	.D SEQ10^VAFHLPI1(HOW,HLQ)
-	;Address (#11)
-	I VAFSTR[11 D
-	.N HOW
-	.S Y=$F(VAFSTR,"11")
-	.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
-	.D SEQ11^VAFHLPI2(HOW,HLQ)
-	;County (#12)
-	I VAFSTR[12 S X1=$P($G(^DIC(5,+$G(VAPA(5)),1,+$G(VAPA(7)),0)),"^",3),VAFY(12)=$S(X1]"":X1,1:HLQ)
-	S X=$G(^DPT(DFN,.13))
-	;Home phone (#13)
-	I VAFSTR[13 S X1=$$HLPHONE^HLFNC($P(X,"^",1)),VAFY(13)=$S(X1]"":X1,1:HLQ)
-	;Business phone (#14)
-	I VAFSTR[14 S X1=$$HLPHONE^HLFNC($P(X,"^",2)),VAFY(14)=$S(X1]"":X1,1:HLQ)
-	;Marital status (#16)
-	I VAFSTR[16 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),VAFY(16)=$S(X="M":"M",X="N":"S",X="S":"A",X]"":X,1:HLQ)
-	;Religious preference (#17) (if blank send 29 (UNKNOWN))
-	I VAFSTR[17 S X=$P($G(^DIC(13,+VADM(9),0)),"^",4),VAFY(17)=$S(X]"":X,1:29)
-	;SSN (#19)
-	I VAFSTR[19 S X=$P(VADM(2),"^",1),VAFY(19)=$S(X]"":X,1:HLQ)
-	;Ethnicity (#22)
-	I VAFSTR[22 D
-	.N HOW
-	.S Y=$F(VAFSTR,"22")
-	.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
-	.D SEQ22^VAFHLPI1(HOW,HLQ)
-	;Birth place (#23)
-	I VAFSTR[23 D
-	.N DGBC,DGBS
-	.S DGBC=$$GET1^DIQ(2,DFN,.092,"I")
-	.S DGBS=$$GET1^DIQ(2,DFN,.093,"E")
-	.S VAFY(23)=DGBC_" "_DGBS
-	;Date of death (#29) & Death indicator (#30) (always included if dead)
-	S X=+VADM(6) I X D
-	.S VAFY(29)=$$HLDATE^HLFNC(X)
-	.S VAFY(30)="Y"
-	;
-QUIT	D KVA^VADPT
-	D MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID)
-	Q OUTPUT
-	;
-ADDR(VAFADDR,VAFCOUNT)	;Return HL7 address
-	; Input  - VAFADDR as address in format:
-	;            line1^line2^line3^city^state^zip+4
-	;          VAFCOUNT as internal value of county (optional)
-	; Output - HL7 v2.3 formatted Address_HLFS_County Code
-	;
-	;      ****Also assumes all HL7 variables returned from****
-	;          INIT^HLTRANS are defined
-	;
-	N X,Y,Z S X=$E(HLECH)
-	;Street address (line 1)
-	S $P(Y,X,1)=$P(VAFADDR,"^",1)
-	;Other designation (line 2)
-	S $P(Y,X,2)=$P(VAFADDR,"^",2)
-	;City
-	S $P(Y,X,3)=$P(VAFADDR,"^",4)
-	;State
-	S $P(Y,X,4)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),0)),"^",2)
-	;Zip
-	S $P(Y,X,5)=$P(VAFADDR,"^",6)
-	;Other geographic designation (line 3)
-	S $P(Y,X,8)=$P(VAFADDR,"^",3)
-	;County
-	S $P(Y,X,9)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),1,+$G(VAFCOUNT),0)),"^",3)
-	F Z=1,2,3,4,5,8,9 I $P(Y,X,Z)="" S $P(Y,X,Z)=HLQ
-	I $G(VAFCOUNT) D
-	.S $P(Y,HLFS,2)=$P(Y,X,9)
-	Q Y
+VAFCPID ;ALB/MLI,PKE-Create generic PID segment ; 21 Nov 2002  3:13 PM
+ ;;5.3;Registration;**91,149,190,415,508**;Aug 13, 1993
+ ;
+ ; This routine returns the HL7 defined PID segment with its
+ ; mappings to DHCP PATIENT file fields.
+ ;
+EN(DFN,VAFSTR,VAFNUM) ; returns PID segment
+ ;  Input - DFN as internal entry number of the PATIENT file
+ ;          VAFSTR as string of fields requested separated by commas
+ ;          VAFNUM as sequential number for SET ID (default=1)
+ ;
+ ;      ****Also assumes all HL7 variables returned from****
+ ;          INIT^HLTRANS are defined
+ ;
+ ; Output - String containing the desired components of the PID segment
+ ;          VAFPID(n) - if the string is longer than 245, the remaining
+ ;                      characters will be returned in VAFPID(n) where
+ ;                      n is a sequential number beginning with 1
+ ;
+ ; WARNING: This routine makes external calls to VADPT.  Non-namespaced
+ ;          variables may be altered.
+ ;
+ N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,VAPA ; calls VADPT...have to NEW
+ S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
+ S DFN=$G(DFN)
+ I DFN']"" G QUIT
+ ;Get demographics and permanent address
+ S VAPA("P")="" D 4^VADPT
+ S VAFSTR=","_VAFSTR_","
+ K VAFY
+ ;Set ID (#1)
+ I VAFSTR[",1," S VAFY(1)=$S($G(VAFNUM):VAFNUM,1:1)
+ ;External ID (#2 - always included)
+ S X=$$GETICN^MPIF001(DFN) S:(+X=-1) X="" S VAFY(2)=$S(X]"":X,1:HLQ)
+ ;Patient ID (#3 - req)
+ S VAFY(3)=$$M10^HLFNC(DFN)
+ ;Alternate ID (#4)
+ I VAFSTR[",4," S X=$G(VA("BID")),VAFY(4)=$S(X]"":X,1:HLQ)
+ ;Name (#5 - req)
+ S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
+ S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
+ ;Mother's maiden name (#6)
+ I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ)
+ ;Date of birth (#7)
+ I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
+ ;Sex (#8)
+ I VAFSTR[",8," S X=$P(VADM(5),"^",1),VAFY(8)=$S("^M^F^"[("^"_X_"^"):X,1:"U")
+ ;Race (#10)
+ I VAFSTR[10 D
+ .N HOW
+ .S Y=$F(VAFSTR,"10")
+ .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
+ .D SEQ10^VAFHLPI1(HOW,HLQ)
+ ;Address (#11)
+ I VAFSTR[11 D
+ .N HOW
+ .S Y=$F(VAFSTR,"11")
+ .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
+ .D SEQ11^VAFHLPI2(HOW,HLQ)
+ ;County (#12)
+ I VAFSTR[12 S X1=$P($G(^DIC(5,+$G(VAPA(5)),1,+$G(VAPA(7)),0)),"^",3),VAFY(12)=$S(X1]"":X1,1:HLQ)
+ S X=$G(^DPT(DFN,.13))
+ ;Home phone (#13)
+ I VAFSTR[13 S X1=$$HLPHONE^HLFNC($P(X,"^",1)),VAFY(13)=$S(X1]"":X1,1:HLQ)
+ ;Business phone (#14)
+ I VAFSTR[14 S X1=$$HLPHONE^HLFNC($P(X,"^",2)),VAFY(14)=$S(X1]"":X1,1:HLQ)
+ ;Marital status (#16)
+ I VAFSTR[16 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),VAFY(16)=$S(X="M":"M",X="N":"S",X="S":"A",X]"":X,1:HLQ)
+ ;Religious preference (#17) (if blank send 29 (UNKNOWN))
+ I VAFSTR[17 S X=$P($G(^DIC(13,+VADM(9),0)),"^",4),VAFY(17)=$S(X]"":X,1:29)
+ ;SSN (#19)
+ I VAFSTR[19 S X=$P(VADM(2),"^",1),VAFY(19)=$S(X]"":X,1:HLQ)
+ ;Ethnicity (#22)
+ I VAFSTR[22 D
+ .N HOW
+ .S Y=$F(VAFSTR,"22")
+ .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
+ .D SEQ22^VAFHLPI1(HOW,HLQ)
+ ;Birth place (#23)
+ I VAFSTR[23 D
+ .N DGBC,DGBS
+ .S DGBC=$$GET1^DIQ(2,DFN,.092,"I")
+ .S DGBS=$$GET1^DIQ(2,DFN,.093,"E")
+ .S VAFY(23)=DGBC_" "_DGBS
+ ;Date of death (#29) & Death indicator (#30) (always included if dead)
+ S X=+VADM(6) I X D
+ .S VAFY(29)=$$HLDATE^HLFNC(X)
+ .S VAFY(30)="Y"
+ ;
+QUIT D KVA^VADPT
+ D MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID)
+ Q OUTPUT
+ ;
+ADDR(VAFADDR,VAFCOUNT) ;Return HL7 address
+ ; Input  - VAFADDR as address in format:
+ ;            line1^line2^line3^city^state^zip+4
+ ;          VAFCOUNT as internal value of county (optional)
+ ; Output - HL7 v2.3 formatted Address_HLFS_County Code
+ ;
+ ;      ****Also assumes all HL7 variables returned from****
+ ;          INIT^HLTRANS are defined
+ ;
+ N X,Y,Z S X=$E(HLECH)
+ ;Street address (line 1)
+ S $P(Y,X,1)=$P(VAFADDR,"^",1)
+ ;Other designation (line 2)
+ S $P(Y,X,2)=$P(VAFADDR,"^",2)
+ ;City
+ S $P(Y,X,3)=$P(VAFADDR,"^",4)
+ ;State
+ S $P(Y,X,4)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),0)),"^",2)
+ ;Zip
+ S $P(Y,X,5)=$P(VAFADDR,"^",6)
+ ;Other geographic designation (line 3)
+ S $P(Y,X,8)=$P(VAFADDR,"^",3)
+ ;County
+ S $P(Y,X,9)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),1,+$G(VAFCOUNT),0)),"^",3)
+ F Z=1,2,3,4,5,8,9 I $P(Y,X,Z)="" S $P(Y,X,Z)=HLQ
+ I $G(VAFCOUNT) D
+ .S $P(Y,HLFS,2)=$P(Y,X,9)
+ Q Y
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCTF.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCTF.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCTF.m	(revision 623)
@@ -1,79 +1,75 @@
-VAFCTF	;BIR/DLR-Utility for capturing patient's Date Last Treated and Event Reason ;9/9/2002
-	;;5.3;Registration;**428,713,766**;Aug 13, 1993;Build 3
-	Q  ; quit if called from the top
-	;
-	;Reference to ^SCE("ADFN" supported by IA# 2953
-	;Reference to EXC^RGHLLOG supported by IA# 2796
-	;Reference to $$ICNLC^MPIF001 supported by IA #3072
-	;
-EN1(VAFCDFN,VAFCSUP)	; determine the LAST TREATMENT DATE for a single
-	; patient
-	; input: VAFCDFN - the dfn of the patient
-	;        VAFCSUP - if 1, suppress add entries to the ADT HL7 PIVOT
-	;                (#391.71) file for TF messaging - VAFCTFMF (optional)
-	; output: VAFCDATE - patient's DATE LAST TREATED
-	;         VAFCENVR - event reason
-	;
-	N ERR,VAFCSITE,VAFCLAST,VAFCSITE,VAFCADMD,VAFCENDT,VAFCDATE,VAFCENVR,VAFCTYPE
-	S U="^"
-	S:'$D(VAFCSITE) VAFCSITE=$$KSP^XUPARAM("INST") ;defines the local facility
-	S (VAFCLAST,VAFCADMD)=$$ADMDIS(VAFCDFN) ; dt_"^"_event type or ""
-	S VAFCADMD=$S(VAFCADMD]"":$P(VAFCADMD,"^"),1:"") ; event dt or null
-	S:$P(VAFCLAST,"^",2)=3!(VAFCLAST="") VAFCENDT=$$ENCDT(VAFCDFN,VAFCADMD)
-	; patient has been discharged or has never been admitted.  Has this
-	; individual been checked out of a clinic? 
-	I $D(VAFCENDT)#2,($P(VAFCLAST,U)) S VAFCLAST=$S(+VAFCENDT>+VAFCLAST:VAFCENDT,1:VAFCLAST)
-	I $D(VAFCENDT)#2,('$P(VAFCLAST,U)) S VAFCLAST=VAFCENDT
-	S VAFCTYPE=$P(VAFCLAST,"^",2),VAFCDATE=+VAFCLAST
-	; input variables to FILE^VAFCTFU
-	; VAFCDFN - patient ien ; VAFCSITE - treating facility
-	; VAFCDATE - date last treated ; VAFCENVR - event reason
-	;
-	I +VAFCDATE'>0 S VAFCDATE="",VAFCENVR=""
-	I +VAFCDATE>0 S VAFCENVR=$S(VAFCTYPE=1:"A1",VAFCTYPE=3:"A2",1:"A3") ;A1=adm;A2=dis;A3=CO
-	N STA,ICN S ICN=$$ICNLC^MPIF001(VAFCDFN),STA=$P($$SITE^VASITE,"^",3)
-	D FILE^VAFCTFU(VAFCDFN,VAFCSITE_U_VAFCDATE_U_VAFCENVR,$G(VAFCSUP),1,.ERR) I $D(ERR(STA)) D EXC^RGHLLOG(212,ERR(STA),VAFCDFN)
-	;
-	Q
-ADMDIS(DFN)	; find the patient's last admission and discharge dates if
-	; they exist.
-	; Input: DFN - ien of the patient (file 2)
-	;Output: a valid discharge/admission date/time concatenated with
-	;        the event type (1=admission, 3=discharge) -or- null
-	N %,VAERR,VAIP S VAIP("D")="LAST" D IN5^VADPT
-	I '+$G(VAIP(17,1)),('+$G(VAIP(13,1))) Q ""
-	; no discharge date, no admission date, return null
-	I '+$G(VAIP(17,1)) Q $P($G(VAIP(13,1)),U)_"^1"
-	; no discharge date, return admission date
-	I '+$G(VAIP(13,1)) Q $P($G(VAIP(17,1)),U)_"^3"
-	; no admission date, return discharge date
-	I +$G(VAIP(17,1))>(+$G(VAIP(13,1))) Q +$G(VAIP(17,1))_"^3"
-	; return discharge date
-	Q +$G(VAIP(13,1))_"^1" ; return admission date
-	;
-ENCDT(DFN,INPDT)	; find the last patient check out date/time.  'ADFN'
-	; cross-reference accessed through DBIA: 2953
-	; Input: DFN  - ien of the patient (file 2)
-	;        INPDT - date (if any) returned from the inpatient admission/
-	;               discharge subroutine     
-	;Output: a valid discharge/admission date/time concatenated with
-	;        the event type (5=check out) -or- null
-	Q:'DFN "" ; we need dfn defined
-	N VAFCDATA,VAFCPURG,VAFCX,VAFCX1,VAFCX2,VAFCX3
-	S VAFCX=9999999.9999999,VAFCX2=0,VAFCX3=""
-	F  S VAFCX=$O(^SCE("ADFN",DFN,VAFCX),-1) Q:'VAFCX!(INPDT>VAFCX)  D  Q:VAFCX2
-	. S VAFCX1=0 F  S VAFCX1=$O(^SCE("ADFN",DFN,VAFCX,VAFCX1)) Q:'VAFCX1  D  Q:VAFCX2
-	.. D GETGEN^SDOE(VAFCX1,"VAFCDATA")
-	.. D PARSE^SDOE(.VAFCDATA,"EXTERNAL","VAFCPARS")
-	.. I $G(VAFCPARS(.12))="CHECKED OUT" S VAFCX2=1,VAFCX3=VAFCX
-	.. K VAFCDATA,VAFCPARS
-	.. Q
-	. Q
-	K VAFCDATA,VAFCPURG,VAFCX,VAFCX1,VAFCX2
-	;DG*5.3*766
-	I $E(VAFCX3,9,10)>23 S VAFCX3=$E(VAFCX3,1,8)_"23"_$E(VAFCX3,11,14)
-	I $E(VAFCX3,11)>5 S VAFCX3=$E(VAFCX3,1,10)_"59"_$E(VAFCX3,13,14)
-	;DG*5.3*713
-	I $E(VAFCX3,13)>5 S VAFCX3=$E(VAFCX3,1,12)_"59"
-	Q VAFCX3_"^5" ; X is either null or the date/time of the check out
-	;
+VAFCTF ;BIR/DLR-Utility for capturing patient's Date Last Treated and Event Reason ;9/9/2002
+ ;;5.3;Registration;**428,713**;Aug 13, 1993
+ Q  ; quit if called from the top
+ ;
+ ;Reference to ^SCE("ADFN" supported by IA# 2953
+ ;Reference to EXC^RGHLLOG supported by IA# 2796
+ ;Reference to $$ICNLC^MPIF001 supported by IA #3072
+ ;
+EN1(VAFCDFN,VAFCSUP) ; determine the LAST TREATMENT DATE for a single
+ ; patient
+ ; input: VAFCDFN - the dfn of the patient
+ ;        VAFCSUP - if 1, suppress add entries to the ADT HL7 PIVOT
+ ;                (#391.71) file for TF messaging - VAFCTFMF (optional)
+ ; output: VAFCDATE - patient's DATE LAST TREATED
+ ;         VAFCENVR - event reason
+ ;
+ N ERR,VAFCSITE,VAFCLAST,VAFCSITE,VAFCADMD,VAFCENDT,VAFCDATE,VAFCENVR,VAFCTYPE
+ S U="^"
+ S:'$D(VAFCSITE) VAFCSITE=$$KSP^XUPARAM("INST") ;defines the local facility
+ S (VAFCLAST,VAFCADMD)=$$ADMDIS(VAFCDFN) ; dt_"^"_event type or ""
+ S VAFCADMD=$S(VAFCADMD]"":$P(VAFCADMD,"^"),1:"") ; event dt or null
+ S:$P(VAFCLAST,"^",2)=3!(VAFCLAST="") VAFCENDT=$$ENCDT(VAFCDFN,VAFCADMD)
+ ; patient has been discharged or has never been admitted.  Has this
+ ; individual been checked out of a clinic? 
+ I $D(VAFCENDT)#2,($P(VAFCLAST,U)) S VAFCLAST=$S(+VAFCENDT>+VAFCLAST:VAFCENDT,1:VAFCLAST)
+ I $D(VAFCENDT)#2,('$P(VAFCLAST,U)) S VAFCLAST=VAFCENDT
+ S VAFCTYPE=$P(VAFCLAST,"^",2),VAFCDATE=+VAFCLAST
+ ; input variables to FILE^VAFCTFU
+ ; VAFCDFN - patient ien ; VAFCSITE - treating facility
+ ; VAFCDATE - date last treated ; VAFCENVR - event reason
+ ;
+ I +VAFCDATE'>0 S VAFCDATE="",VAFCENVR=""
+ I +VAFCDATE>0 S VAFCENVR=$S(VAFCTYPE=1:"A1",VAFCTYPE=3:"A2",1:"A3") ;A1=adm;A2=dis;A3=CO
+ N STA,ICN S ICN=$$ICNLC^MPIF001(VAFCDFN),STA=$P($$SITE^VASITE,"^",3)
+ D FILE^VAFCTFU(VAFCDFN,VAFCSITE_U_VAFCDATE_U_VAFCENVR,$G(VAFCSUP),1,.ERR) I $D(ERR(STA)) D EXC^RGHLLOG(212,ERR(STA),VAFCDFN)
+ ;
+ Q
+ADMDIS(DFN) ; find the patient's last admission and discharge dates if
+ ; they exist.
+ ; Input: DFN - ien of the patient (file 2)
+ ;Output: a valid discharge/admission date/time concatenated with
+ ;        the event type (1=admission, 3=discharge) -or- null
+ N %,VAERR,VAIP S VAIP("D")="LAST" D IN5^VADPT
+ I '+$G(VAIP(17,1)),('+$G(VAIP(13,1))) Q ""
+ ; no discharge date, no admission date, return null
+ I '+$G(VAIP(17,1)) Q $P($G(VAIP(13,1)),U)_"^1"
+ ; no discharge date, return admission date
+ I '+$G(VAIP(13,1)) Q $P($G(VAIP(17,1)),U)_"^3"
+ ; no admission date, return discharge date
+ I +$G(VAIP(17,1))>(+$G(VAIP(13,1))) Q +$G(VAIP(17,1))_"^3"
+ ; return discharge date
+ Q +$G(VAIP(13,1))_"^1" ; return admission date
+ ;
+ENCDT(DFN,INPDT) ; find the last patient check out date/time.  'ADFN'
+ ; cross-reference accessed through DBIA: 2953
+ ; Input: DFN  - ien of the patient (file 2)
+ ;        INPDT - date (if any) returned from the inpatient admission/
+ ;               discharge subroutine     
+ ;Output: a valid discharge/admission date/time concatenated with
+ ;        the event type (5=check out) -or- null
+ Q:'DFN "" ; we need dfn defined
+ N VAFCDATA,VAFCPURG,VAFCX,VAFCX1,VAFCX2,VAFCX3
+ S VAFCX=9999999.9999999,VAFCX2=0,VAFCX3=""
+ F  S VAFCX=$O(^SCE("ADFN",DFN,VAFCX),-1) Q:'VAFCX!(INPDT>VAFCX)  D  Q:VAFCX2
+ . S VAFCX1=0 F  S VAFCX1=$O(^SCE("ADFN",DFN,VAFCX,VAFCX1)) Q:'VAFCX1  D  Q:VAFCX2
+ .. D GETGEN^SDOE(VAFCX1,"VAFCDATA")
+ .. D PARSE^SDOE(.VAFCDATA,"EXTERNAL","VAFCPARS")
+ .. I $G(VAFCPARS(.12))="CHECKED OUT" S VAFCX2=1,VAFCX3=VAFCX
+ .. K VAFCDATA,VAFCPARS
+ .. Q
+ . Q
+ K VAFCDATA,VAFCPURG,VAFCX,VAFCX1,VAFCX2
+ I $E(VAFCX3,13)>5 S VAFCX3=$E(VAFCX3,1,12)_"59"
+ Q VAFCX3_"^5" ; X is either null or the date/time of the check out
+ ;
Index: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPID.m
===================================================================
--- WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPID.m	(revision 613)
+++ WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPID.m	(revision 623)
@@ -1,93 +1,91 @@
-VAFHLPID	;ALB/MLI/ESD - Create generic PID segment ; 21 Nov 2002  3:13 PM
-	;;5.3;Registration;**68,94,415,508,749**;Aug 13, 1993;Build 10
-	;
-	; This routine returns the HL7 defined PID segment with its
-	; mappings to DHCP PATIENT file fields.
-	;
-EN(DFN,VAFSTR,VAFNUM,PTID)	; returns PID segment
-	;  Input - DFN as internal entry number of the PATIENT file
-	;          VAFSTR as string of fields requested separated by commas
-	;          VAFNUM as sequential number for SET ID (default=1)
-	;          PTID is flag denoting which Patient ID (seq 3) to use
-	;              0 - Use DFN formatted as data type CK (default)
-	;              1 - Use ICN
-	;              2 - Use DFN formatted as data type CX
-	;              3 - Use SSN (with dashes)
-	;
-	;      ****Also assumes all HL7 variables returned from****
-	;          INIT^HLTRANS are defined
-	;
-	; Output - String containing the desired components of the PID segment
-	;          VAFPID(n) - if the string is longer than 245, the remaining
-	;                      characters will be returned in VAFPID(n) where
-	;                      n is a sequential number beginning with 1
-	;
-	; WARNING: This routine makes external calls to VADPT.  Non-namespaced
-	;          variables may be altered.
-	;
-	N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA ; calls VADPT...have to NEW
-	S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
-	S DFN=$G(DFN)
-	I DFN']"" G QUIT
-	;Get demographics and permanent address
-	S VAPA("P")="" D 4^VADPT
-	S VAFSTR=","_VAFSTR_","
-	K VAFY
-	;Set ID (#1)
-	I VAFSTR[",1," S VAFY(1)=$S($G(VAFNUM):VAFNUM,1:1)
-	;External ID (#2)
-	I VAFSTR[",2," S X=$G(VA("PID")),VAFY(2)=$S(X]"":$$M10^HLFNC(X),1:HLQ)
-	;Patient ID (#3 - req)
-	S PTID=+$G(PTID)
-	I 'PTID S VAFY(3)=$$M10^HLFNC(DFN)
-	I PTID D
-	.S X=$S(PTID=1:"NI",PTID=2:"PI",PTID=3:"SS")
-	.S VAFY(3)=$$SEQ3^VAFHLPI1(DFN,X,HLECH,HLQ)
-	;Alternate ID (#4)
-	I VAFSTR[",4," S X=$G(VA("BID")),VAFY(4)=$S(X]"":X,1:HLQ)
-	;Name (#5 - req)
-	S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
-	S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
-	;Mother's maiden name (#6)
-	I VAFSTR[",6," D
-	.S DGMMN("FILE")=2,DGMMN("IENS")=DFN,DGMMN("FIELD")=.2403
-	.S X=$$HLNAME^XLFNAME(.DGMMN,"",$E(HLECH)),VAFY(6)=$S(X]"":X,1:HLQ)
-	;Date of birth (#7)
-	I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
-	;Sex (#8)
-	I VAFSTR[",8," S X=$P(VADM(5),"^",1),VAFY(8)=$S("^M^F^"[("^"_X_"^"):X,1:"U")
-	;Race (#10)
-	I VAFSTR[10 D
-	.N HOW
-	.S Y=$F(VAFSTR,"10")
-	.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
-	.D SEQ10^VAFHLPI1(HOW,HLQ)
-	;Address (#11)
-	I VAFSTR[11 D
-	.N HOW
-	.S Y=$F(VAFSTR,"11")
-	.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
-	.D SEQ11^VAFHLPI2(HOW,HLQ)
-	;County (#12)
-	I VAFSTR[12 S X1=$P($G(^DIC(5,+$G(VAPA(5)),1,+$G(VAPA(7)),0)),"^",3),VAFY(12)=$S(X1]"":X1,1:HLQ)
-	S X=$G(^DPT(DFN,.13))
-	;Home phone (#13)
-	I VAFSTR[13 S X1=$$HLPHONE^HLFNC($P(X,"^",1)),VAFY(13)=$S(X1]"":X1,1:HLQ)
-	;Business phone (#14)
-	I VAFSTR[14 S X1=$$HLPHONE^HLFNC($P(X,"^",2)),VAFY(14)=$S(X1]"":X1,1:HLQ)
-	;Marital status (#16)
-	I VAFSTR[16 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),VAFY(16)=$S(X="N":"S",X="U":"",X="":HLQ,1:X)
-	;Religious preference (#17) (if blank send 29 (UNKNOWN))
-	I VAFSTR[17 S X=$P($G(^DIC(13,+VADM(9),0)),"^",4),VAFY(17)=$S(X]"":X,1:29)
-	;SSN (#19)
-	I VAFSTR[19 S X=$P(VADM(2),"^",1),VAFY(19)=$S(X]"":X,1:HLQ)
-	;Ethnicity (#22)
-	I VAFSTR[22 D
-	.N HOW
-	.S Y=$F(VAFSTR,"22")
-	.S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
-	.D SEQ22^VAFHLPI1(HOW,HLQ)
-	;
-QUIT	D KVA^VADPT
-	D MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID)
-	Q OUTPUT
+VAFHLPID ;ALB/MLI/ESD - Create generic PID segment ; 21 Nov 2002  3:13 PM
+ ;;5.3;Registration;**68,94,415,508**;Aug 13, 1993
+ ;
+ ; This routine returns the HL7 defined PID segment with its
+ ; mappings to DHCP PATIENT file fields.
+ ;
+EN(DFN,VAFSTR,VAFNUM,PTID) ; returns PID segment
+ ;  Input - DFN as internal entry number of the PATIENT file
+ ;          VAFSTR as string of fields requested separated by commas
+ ;          VAFNUM as sequential number for SET ID (default=1)
+ ;          PTID is flag denoting which Patient ID (seq 3) to use
+ ;              0 - Use DFN formatted as data type CK (default)
+ ;              1 - Use ICN
+ ;              2 - Use DFN formatted as data type CX
+ ;              3 - Use SSN (with dashes)
+ ;
+ ;      ****Also assumes all HL7 variables returned from****
+ ;          INIT^HLTRANS are defined
+ ;
+ ; Output - String containing the desired components of the PID segment
+ ;          VAFPID(n) - if the string is longer than 245, the remaining
+ ;                      characters will be returned in VAFPID(n) where
+ ;                      n is a sequential number beginning with 1
+ ;
+ ; WARNING: This routine makes external calls to VADPT.  Non-namespaced
+ ;          variables may be altered.
+ ;
+ N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,VAPA ; calls VADPT...have to NEW
+ S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
+ S DFN=$G(DFN)
+ I DFN']"" G QUIT
+ ;Get demographics and permanent address
+ S VAPA("P")="" D 4^VADPT
+ S VAFSTR=","_VAFSTR_","
+ K VAFY
+ ;Set ID (#1)
+ I VAFSTR[",1," S VAFY(1)=$S($G(VAFNUM):VAFNUM,1:1)
+ ;External ID (#2)
+ I VAFSTR[",2," S X=$G(VA("PID")),VAFY(2)=$S(X]"":$$M10^HLFNC(X),1:HLQ)
+ ;Patient ID (#3 - req)
+ S PTID=+$G(PTID)
+ I 'PTID S VAFY(3)=$$M10^HLFNC(DFN)
+ I PTID D
+ .S X=$S(PTID=1:"NI",PTID=2:"PI",PTID=3:"SS")
+ .S VAFY(3)=$$SEQ3^VAFHLPI1(DFN,X,HLECH,HLQ)
+ ;Alternate ID (#4)
+ I VAFSTR[",4," S X=$G(VA("BID")),VAFY(4)=$S(X]"":X,1:HLQ)
+ ;Name (#5 - req)
+ S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
+ S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
+ ;Mother's maiden name (#6)
+ I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ)
+ ;Date of birth (#7)
+ I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
+ ;Sex (#8)
+ I VAFSTR[",8," S X=$P(VADM(5),"^",1),VAFY(8)=$S("^M^F^"[("^"_X_"^"):X,1:"U")
+ ;Race (#10)
+ I VAFSTR[10 D
+ .N HOW
+ .S Y=$F(VAFSTR,"10")
+ .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
+ .D SEQ10^VAFHLPI1(HOW,HLQ)
+ ;Address (#11)
+ I VAFSTR[11 D
+ .N HOW
+ .S Y=$F(VAFSTR,"11")
+ .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
+ .D SEQ11^VAFHLPI2(HOW,HLQ)
+ ;County (#12)
+ I VAFSTR[12 S X1=$P($G(^DIC(5,+$G(VAPA(5)),1,+$G(VAPA(7)),0)),"^",3),VAFY(12)=$S(X1]"":X1,1:HLQ)
+ S X=$G(^DPT(DFN,.13))
+ ;Home phone (#13)
+ I VAFSTR[13 S X1=$$HLPHONE^HLFNC($P(X,"^",1)),VAFY(13)=$S(X1]"":X1,1:HLQ)
+ ;Business phone (#14)
+ I VAFSTR[14 S X1=$$HLPHONE^HLFNC($P(X,"^",2)),VAFY(14)=$S(X1]"":X1,1:HLQ)
+ ;Marital status (#16)
+ I VAFSTR[16 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),VAFY(16)=$S(X="N":"S",X="U":"",X="":HLQ,1:X)
+ ;Religious preference (#17) (if blank send 29 (UNKNOWN))
+ I VAFSTR[17 S X=$P($G(^DIC(13,+VADM(9),0)),"^",4),VAFY(17)=$S(X]"":X,1:29)
+ ;SSN (#19)
+ I VAFSTR[19 S X=$P(VADM(2),"^",1),VAFY(19)=$S(X]"":X,1:HLQ)
+ ;Ethnicity (#22)
+ I VAFSTR[22 D
+ .N HOW
+ .S Y=$F(VAFSTR,"22")
+ .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1)
+ .D SEQ22^VAFHLPI1(HOW,HLQ)
+ ;
+QUIT D KVA^VADPT
+ D MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID)
+ Q OUTPUT
