Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG10.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGCV.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEATH.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENA2.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENUPLB.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGLBPID.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMSTAPI.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTCOU1.m

-              r613
+              r623
 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
 (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
+(X1,DGDT) ; RETURNS 1 IF X1 IS MORE THAN 1 YEAR BEFORE DGDT
+ Q X1+10000'>DGDT

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTU.m

-              r613
+              r623
 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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m

-              r613
+              r623
 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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTF4.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFDEL.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM4.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTR1.m

-              r613
+              r623
 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 #
       ;;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
+        ;
       ;;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
      ;;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
+        ;
       ;;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
+        ;
       ;;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;
+        ;
       ;;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
+        ;
       ;;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 #
+ ;;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
+ ;
+ ;;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
+ ;;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
+ ;
+ ;;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
+ ;
+ ;;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;
+ ;
+ ;;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
+ ;
+ ;;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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAED.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAZL.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP14.m

-              r613
+              r623
 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"

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP2.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP3.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m

-              r613
+              r623
 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
+        ;
       ;;.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^");
       ;;.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^");
       ;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25;
       ;;
       ;;
       ;;
       ;;.36205;S:X'="Y" Y="@29";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim A&A" S Y=.36205;.36295;@29;
       ;;.36215;S:X'="Y" Y="@30";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim HOUSEBOUND" S Y=.36215;.36295;@30;
       ;;.36235;S:X'="Y" Y="@31";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim VA PENSION" S Y=.36235;.36295;@31;
       ;;.36255;S:X'="Y" Y="@32";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim MIL. RET." S Y=.36255;.3625;@32;
       ;;
       ;;.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;
       ;;
       ;;.525;S:X'="Y" Y="@37";.526:.528;@37;
       ;;.525;S:X'="Y" Y="@38";.526:.528;@38;
       ;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39;
       ;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40;
       ;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41;
       ;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42;
       ;;
       ;;
       ;;
       ;;
       ;;
       ;;.36265;S:X'="Y" Y="@48";.3626;@48;
       ;;I DGVTYN'="Y" S Y="@51";.324:.328;@51;
       ;;.3025;S:X'="Y" Y="@56";.36295;@56;
       ;;.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
+ ;
+ ;;.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^");
+ ;;.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^");
+ ;;.323;.32102;S:X'="Y" Y="@25";.32107;.3211;.32109;.3213;@25;
+ ;;
+ ;;
+ ;;
+ ;;.36205;S:X'="Y" Y="@29";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim A&A" S Y=.36205;.36295;@29;
+ ;;.36215;S:X'="Y" Y="@30";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim HOUSEBOUND" S Y=.36215;.36295;@30;
+ ;;.36235;S:X'="Y" Y="@31";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim VA PENSION" S Y=.36235;.36295;@31;
+ ;;.36255;S:X'="Y" Y="@32";I DGVTYN'="Y" W !,"Patient not a veteran-can't claim MIL. RET." S Y=.36255;.3625;@32;
+ ;;
+ ;;.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;
+ ;;
+ ;;.525;S:X'="Y" Y="@37";.526:.528;@37;
+ ;;.525;S:X'="Y" Y="@38";.526:.528;@38;
+ ;;.5291;S:X'="Y" Y="@39";.5292:.5294;@39;
+ ;;.5291;S:X'="Y" Y="@40";.5292:.5294;@40;
+ ;;.32101;S:X'="Y" Y="@41";.32104;.32105;@41;
+ ;;.32101;S:X'="Y" Y="@42";.32104;.32105;@42;
+ ;;
+ ;;
+ ;;
+ ;;
+ ;;
+ ;;.36265;S:X'="Y" Y="@48";.3626;@48;
+ ;;I DGVTYN'="Y" S Y="@51";.324:.328;@51;
+ ;;.3025;S:X'="Y" Y="@56";.36295;@56;
+ ;;.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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPD.m

-              r613
+              r623
 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
+ ;

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDB.m

-              r613
+              r623
+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
+ ;

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m

-              r613
+              r623
 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
+        ;
      ;;
      ;;1;
      ;;.091;
      ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
      ;;.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;
   ;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^");
      ;;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^");
      ;;.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;
   ;;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^");
      ;;.134;.135;.133
      ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
      ;;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^");
      ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
      ;;.181;
      ;;.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;
      ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
   ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
      ;;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;
   ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
   ;;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;
   ;;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;
      ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;
      ;;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;
   ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
   ;;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
   ;;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;
      ;;.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;
      ;;.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;
      ;;
      ;;.381;.382///NOW;
      ;;.383;
      ;;@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";
   ;;@60111;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y);.32911;@6011;.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@60199";
   ;;@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";
   ;;@60112;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y);.32912;@6012;.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@60199";
   ;;@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";
   ;;@60113;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y);.32913;@6013;.3299;.3297;.3298;.3295;@60199;
      ;;Q;
      ;;Q;
      ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
      ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
      ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
      ;;.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;
      ;;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
+ ;
+ ;;
+ ;;1;
+ ;;.091;
+ ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
+ ;;.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;
+ ;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^");
+ ;;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^");
+ ;;.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;
+ ;;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^");
+ ;;.134;.135;.133
+ ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
+ ;;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^");
+ ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
+ ;;.181;
+ ;;.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;
+ ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
+ ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
+ ;;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;
+ ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
+ ;;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;
+ ;;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;
+ ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;
+ ;;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;
+ ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
+ ;;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
+ ;;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;
+ ;;.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;
+ ;;.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;
+ ;;
+ ;;.381;.382///NOW;
+ ;;.383;
+ ;;@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";
+ ;;@60111;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y);.32911;@6011;.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@60199";
+ ;;@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";
+ ;;@60112;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y);.32912;@6012;.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@60199";
+ ;;@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";
+ ;;@60113;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y);.32913;@6013;.3299;.3297;.3298;.3295;@60199;
+ ;;Q;
+ ;;Q;
+ ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
+ ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
+ ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
+ ;;.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;
+ ;;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)
+ ;

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX.m

-              r613
+              r623
 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)=%
 …
 C3F1 Q
 X3 Q
 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391
+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,"
 …
 C4F2 Q
 X4 Q
 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
+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;"
 …
  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
 …
  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)
 …
  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
 …
  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
 …
 X10 S:X="" Y="@1112"
+ Q
+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
+ ;
+S DQ=13 ;@1112
+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
+D:$D(DG)>9 F^DIE17 G ^DGRPTX5
+D:$D(DG)>9 F^DIE17 G ^DGRPTX4

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX1.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX10.m

-              r613
+              r623
+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
+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
+ ;
+D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A
+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
+ ;
+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
+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
+ ;
+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
+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
+ ;
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+S DQ=16 ;@30
+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
+D:$D(DG)>9 F^DIE17 G ^DGRPTX13

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX11.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX12.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX13.m

-              r613
+              r623
+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
+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
+ ;
+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
+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
+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
+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
+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
+ ;
+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
+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
+ ;
+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
+ ;
+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
+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
+ ;
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+D:$D(DG)>9 F^DIE17 G ^DGRPTX16

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX14.m

-              r613
+              r623
+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))

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX15.m

-              r613
+              r623
+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))

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX16.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
+S DQ=4 ;@40
+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
+ ;
+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
+ ;
+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
+ ;
+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
+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
+ ;
+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
+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
+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
+S DQ=13 ;@532
+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
+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
+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
+S DQ=17 ;@533
+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
+D:$D(DG)>9 F^DIE17 G ^DGRPTX17

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX17.m

-              r613
+              r623
 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
+ ;
 …
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="DGRPTX17",DQ=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
+ ;
+D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A
+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
+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
+S DQ=3 ;@53
+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
+ ;
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+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
+ ;
+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
+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
+ ;
+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
+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
+ ;
+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
+ ;
+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
+ ;
+S DQ=11 ;@50
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+S DQ=16 ;@30
+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
+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
+ ;
+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
+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
+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
+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
+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
+ ;
+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
+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
+ ;
+D:$D(DG)>9 F^DIE17 G ^DGRPTX24

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX18.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX19.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX2.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX20.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
+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
+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
+ ;
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+S DQ=13 ;@40
+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
+ ;
+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
+ ;
+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
+ ;
-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
-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
+ ;
-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
-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
-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
-S DQ=22 ;@532
-D:$D(DG)>9 F^DIE17 G ^DGRPTX22

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX21.m

-              r613
+              r623
 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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX22.m

-              r613
+              r623
+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
+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
+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
+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
+S DQ=5 ;@533
+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
+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
+S DQ=8 ;@53
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
-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
-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
+ ;
-S DQ=16 ;@50
-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
+ ;
-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
+ ;
-D:$D(DG)>9 F^DIE17 G ^DGRPTX29

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX23.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX24.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+S DQ=6 ;@98
+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
+G 0^DIE17

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX25.m

-              r613
+              r623
+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
+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
+ ;
+G 1^DIE17

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX26.m

-              r613
+              r623
+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
+ ;;
+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
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX27.m

-              r613
+              r623
+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
+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
+ ;
+G 1^DIE17

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX28.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX29.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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)=""
 …
  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
+ ;
+S DQ=6 ;@98
+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
+G 0^DIE17
+ I $D(DE(8))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX3.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX30.m

-              r613
+              r623
 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
+ ;;
+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
-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
+ ;
-G 1^DIE17

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX4.m

-              r613
+              r623
+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
+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
+ ;
+S DQ=3 ;@1112
+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
+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
+ ;
+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
+ ;
+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
+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
+D:$D(DG)>9 F^DIE17 G ^DGRPTX9

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX5.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
+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
+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
+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
 …
  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
+ ;
-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
+ ;
-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
+ ;
-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
-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
-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
+ ;
-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
-D:$D(DG)>9 F^DIE17 G ^DGRPTX17

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX6.m

-              r613
+              r623
 DGRPTX6 ; ;12/13/08
+DGRPTX6 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
 …
  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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX7.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX8.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX9.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+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
+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
+ ;
+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
+D:$D(DG)>9 F^DIE17 G ^DGRPTX10

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m

-              r613
+              r623
 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
+ ;

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPV.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX7.m

-              r613
+              r623
 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)=%
 …
 X1 S:DGDR'["701" Y="@702"
+ Q
 S DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391
+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,"
 …
 X3 D SC7^DGRPV
+ Q
 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
+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;"
 …
+ Q
+ ;
 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".3;1",DV="SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301
+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;"
 …
  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
 …
+ Q
+ ;
+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
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+S DQ=18 ;@702
+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
+D:$D(DG)>9 F^DIE17 G ^DGRPX74
+D:$D(DG)>9 F^DIE17 G ^DGRPX73

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX71.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX72.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX73.m

-              r613
+              r623
+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
+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
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+S DQ=8 ;@702
+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
+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
+ ;
+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
+ ;
+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
+ ;
+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
+ ;
+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
+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
+ ;
+D:$D(DG)>9 F^DIE17 G ^DGRPX710

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX74.m

-              r613
+              r623
+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
+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
+ ;
-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
+ ;
-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
+ ;
-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
+ ;
-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
-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
+ ;
-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
+ ;
-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
-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
+ ;
-S DQ=11 ;@703
-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
-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
+ ;
-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
-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
+ ;
-D:$D(DG)>9 F^DIE17 G ^DGRPX77

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX75.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX76.m

-              r613
+              r623
+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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX77.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
-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
-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
-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
+ ;
-S DQ=7 ;@704
-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
-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
+ ;
-S DQ=10 ;@99
-G 0^DIE17

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX78.m

-              r613
+              r623
+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
+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
+ ;
+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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX79.m

-              r613
+              r623
+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
+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
+ ;
+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
+ ;
+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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPXR.m

-              r613
+              r623
 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,""))=""
 …
  M DIEZAR=^DIE(422,"AR") S DICRREC="TRIG^DIE17"
  S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=422,U="^"
 S DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
+S DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
  S DE(DW)="C1^DGRPXR"
  S DU="Y:YES;N:NO;"
 …
  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
 …
  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)
 …
  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
 …
  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"
 …
  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
 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVICE",DIFLD=.323
 …
  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)=""
 …
  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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA01.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA08.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA22.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGBJ.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL.m

-              r613
+              r623
+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
+ ;

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADATE.m

-              r613
+              r623
 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m

-              r613
+              r623
 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
        ;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
+        ;
        ;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
+        ;
        ;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
+        ;
        ;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
+ ;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
+ ;
+ ;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
+ ;
+ ;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
+ ;
+ ;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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT2.m

-              r613
+              r623
 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
        ; -- 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
+ ; -- 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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m

-              r613
+              r623
 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]
        ;
+        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
+        ;
       ; -- 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
+        ;
       ; -- 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]
+ ;
+ 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
+ ;
+ ; -- 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
+ ;
+ ; -- 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)

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT5.m

-              r613
+              r623
 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
       ;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
      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
      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
+        ;
       ;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
      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
+        ;
       ;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
      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
      ;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
+ ;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
+ 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
+ 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
+ ;
+ ;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
+ 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
+ ;
+ ;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
+ 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
+ ;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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m

-              r613
+              r623
 VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
+        ;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
+        ;
        ;;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
+        ;
        ;;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
+ ;
+ ;;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
+ ;
+ ;;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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID.m

-              r613
+              r623
+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

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCTF.m

-              r613
+              r623
+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
+ ;

WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPID.m

-              r613
+              r623
+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

Context Navigation

Legend:

Download in other formats: