Ignore:
Timestamp:
Dec 4, 2009, 8:26:01 PM (15 years ago)
Author:
George Lilly
Message:

WorldVistAEHR overlayed on FOIAVistA

Location:
FOIAVistA/tag/r
Files:
179 edited
1 copied

Legend:

Unmodified
Added
Removed

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

    r628 r636  
    1 DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 8/24/05 1:47pm
    2  ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658**;Aug 13, 1993
     1DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 1/5/2006  21:46
     2 ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319START ;
    420 D LO^DGUTL
    … …  
    723 . D EN^DGRPD
    824 . Q:$G(DGRPOUT)
    9  . D REG^IVMCQ($G(DFN))
     25 . ;
     26 . ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
     27 . ;
     28 . ; HEC query call only wanted/needed for VA agency code
     29 . ;
     30 . I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
     31 . ;
     32 . ; ** end of VOE change 1 **
     33 . ;
    1034 . D HINQ
    1135 ;
    … …  
    1741 N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
    1842 K MPIFRTN
    19  D MPIQ^MPIFAPI(DFN)
     43 ;
     44 ; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
     45 ;
     46 ; MPI query call only wanted/needed for VA agency code
     47 ;
     48 I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
     49 ;
     50 ; ** end of VOE change 2 **
     51 ;
    2052 K MPIFRTN
    2153 ;
    … …  
    2759SKIP ;
    2860 S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
    29  D HINQ,REG^IVMCQ($G(DFN)) G A1
     61 ;
     62 ; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
     63 ;
     64 ; these query calls only wanted/needed for VA agency code
     65 ;
     66 I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
     67 G A1
     68 ;
     69 ; ** end of VOE change 3 **
     70 ;
    3071 ;
    3172HINQ ;

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

    r628 r636  
    1 DGCV ;ALB/DW,ERC,BRM,TMK - COMBAT VET ELIGIBILTY; 10/15/05 ; 3/24/08 7:28am
    2  ;;5.3;Registration;**528,576,564,673,778**; Aug 13, 1993;Build 9
     1DGCV ;ALB/DW,ERC,BRM,TMK - COMBAT VET ELIGIBILTY; 10/15/05
     2 ;;5.3;Registration;**528,576,564,673**; Aug 13, 1993
    33 ;
    44CVELIG(DFN) ;
    5  ;API will determine whether or not this veteran needs to have CV End
     5 ;API will determine whether or not this vetearn needs to have CV End
    66 ;Date set.  If this determination cannot be done due to imprecise
    77 ;or missing dates, it returns which dates need editing.
    … …  
    1010 ;Output
    1111 ;  RESULT
    12  ;    0 - CV End Date should not be set
    13  ;    1 - CV End Date should be set
     12 ;    0 - CV End Date should not be updated
     13 ;    1 - CV End Date should be updated
    1414 ;  If critical dates are imprecise return the following
    15  ;    A - CV End Date should not be set, imprecise Service Sep date
    16  ;    B - CV End Date should not be set, imprecise Combat To date
    17  ;    C - CV End Date should not be set, imprecise Yugoslavia To date
    18  ;    D - CV End Date should not be set, imprecise Somalia To date
    19  ;    E - CV End Date should not be set, imprecise Pers Gulf To date
     15 ;    A - CV End Date should not be updated, imprecise Service Sep date
     16 ;    B - CV End Date should not be updated, imprecise Combat To date
     17 ;    C - CV End Date should not be updated, imprecise Yugoslavia To date
     18 ;    D - CV End Date should not be updated, imprecise Somalia To date
     19 ;    E - CV End Date should not be updated, imprecise Pers Gulf To date
    2020 ;  If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
    2121 ;    OEF/OIF records on file, return the following so that it  will
    … …  
    8484 ;
    8585SETCV(DFN,DGSRV) ;calculate CV end date
    86  ;    DGSRV is the most recent of the Service Separation Date
    87  ;    or the OEF/OIF To Date, called from file #2 new style
    88  ;    cross reference "ACVCOM"
    89  N DGCVEDT,DGFDA,DGNDAA,DGPLUS3,DGTMPDT,DGYRS
    90  S DGNDAA=3080128
     86 K DGCVEDT
     87 N DGFDA
    9188 I $G(DFN)']""!($G(DGSRV)']"") Q
    9289 I '$D(^DPT(DFN)) Q
     90 S DGCVEDT=$P($$SCH^XLFDT("24M",DGSRV),".")
     91 I DGCVEDT=$G(DGCVDT) Q
    9392 I $$GET1^DIQ(2,DFN_",",.5295,"I") Q
    94  D CVRULES(DFN,DGSRV,.DGYRS)
    95  Q:$G(DGYRS)'=3&($G(DGYRS)'=5)
    96  ;NDAA legislation, enacted 1/28/08, gives vets discharged
    97  ;on or after 1/28/03 (2 years previously) CV Eligibility
    98  ;for 5 years.  Vets discharged before 1/28/03 get eligibility
    99  ;for 3 years after enactment (or until 1/27/2011) DG*5.3*778
    100  S DGTMPDT=$S(DGYRS=3:DGNDAA,1:DGSRV)
    101  S DGCVEDT=($E(DGTMPDT,1,3)+DGYRS)_$E(DGTMPDT,4,7)
    102  S DGCVEDT=$$FMADD^XLFDT(DGCVEDT,-1)
    10393 S DGFDA(2,DFN_",",.5295)=DGCVEDT
    10494 D FILE^DIE(,"DGFDA")
    105  Q
    106  ;
    107 CVRULES(DFN,DGSRV,DGYRS) ;apply rules for the CV End Date
    108  ;extension project - DG*5.3*778
    109  ;DGSRV - most recent of Service Sep Date or OEIUUF to date
    110  ;   DGYRS = 3 years from NDAA or 1/27/2011
    111  ;         = 5 years from SSD or Enrollment App Date
    112  ;determine how many years extra CV eligibility to give
    113  N DGCIEN,DGCUTOFF,DGENRDT,DGPIEN,DGPRI,DGQT,DGSTAT
    114  ;determine if veteran has an enrollment record prior
    115  ;to 1/28/2008 (the NDAA date) and no CV End Date for
    116  ;this enrollment
    117  S DGYRS=5
    118  S (DGPRI,DGQT)=0
    119  S DGCUTOFF=3030128
    120  S DGCIEN=$$FINDCUR^DGENA(DFN)
    121  I $G(DGCIEN),($D(^DGEN(27.11,DGCIEN,0)))]"" D
    122  . S DGENRDT=$$GET1^DIQ(27.11,DGCIEN_",",75.01,"I") Q:$G(DGENRDT)']""
    123  . I $P(DGENRDT,".",1)<DGNDAA S DGPRI=1 Q
    124  . I DGENRDT'<DGNDAA D
    125  . . S DGPIEN=DGCIEN
    126  . . F  S DGPIEN=$$FINDPRI^DGENA(DGPIEN) Q:'DGPIEN  D  Q:DGQT
    127  . . . S DGENRDT=$$GET1^DIQ(27.11,DGPIEN_",",75.01,"I")
    128  . . . Q:$G(DGENRDT)']""
    129  . . . I $P(DGENRDT,".",1)<DGNDAA S (DGPRI,DGQT)=1
    130  ;if DGPRI=1, then there is an enrollment prior to 1/28/08
    131  I DGPRI=1 D  Q
    132  . I $G(DGCIEN)]"" S DGSTAT=$$GET1^DIQ(27.11,DGCIEN_",",.04,"E")
    133  . I $G(DGSTAT)["INITIAL APPLICATION BY VAMC"!($G(DGSTAT)["BELOW ENROLLMENT GROUP THRESHOLD") D
    134  . . I DGSRV<DGCUTOFF S DGYRS=3
    135  ;
    136  ;if no enrollment prior to 1/28/08 (DGPRI=0) check service date
    137  ;against cutoff date - 1/28/03
    138  I DGSRV<DGCUTOFF S DGYRS=3
    13995 Q
    14096 ;

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

    r628 r636  
    11DGDEATH ;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 10/27/04 9:45pm
    2  ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725,772**;Aug 13, 1993;Build 4
     2 ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725**;Aug 13, 1993;Build 12
    33 ;
    44GET N DGMTI,DATA
    … …  
    1414 I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE
    1515 I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET
    16 SN I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE I $P($G(^DPT(DFN,.35)),"^",3)']"" D SNDISP G SN
     16 I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE
    1717 I DGDOLD'=DGDNEW D DISCHRGE
    1818 I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR
    … …  
    143143 I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1
    144144 Q
    145 SNDISP ; Source of Notification display choices
    146  N DIR,DTOUT,DUOUT,DIRUT,DIROUT,DGLIST,DGLNAME,I,X,Y
    147  S DGLIST=$P($G(^DD(2,.353,0)),"^",3)
    148  S Y=6
    149  S DIR("?",1)=" "
    150  S DIR("?",2)=" This is a required response. Please select from the following:"
    151  S DIR("?",3)=" Entering '^' will take you back to the Source of Notification prompt"
    152  S DIR("?",4)=" "
    153  S DIR("?",5)=" "
    154  F X=1:1 S DGLNAME=$P(DGLIST,";",X) Q:DGLNAME']""  S DIR("?",Y)="      "_$P(DGLNAME,":",1)_"      "_$P(DGLNAME,":",2) S Y=Y+1
    155  S DIR("?",Y)=" "
    156  F I=1:1 Q:'$D(DIR("?",I))  W !,DIR("?",I)
    157  Q

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

    r628 r636  
    1 DGMSTAPI ;ALB/SCK - API's for Military Sexual Trauma ; 2/28/02 4:56pm
    2  ;;5.3;Registration;**195,243,308,353,379,443,700**;Aug 13, 1993
     1DGMSTAPI ;ALB/SCK - API's for Military Sexual Trauma ;7:34 PM  30 Jan 2008
     2 ;;5.3;Registration;**195,243,308,353,379,443,700,VWEHR1**;WorldVistA 30-Jan-08
     3 ;
     4 ;Modified from FOIA VISTA,
     5 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     6 ;General Public License See attached copy of the License.
     7 ;
     8 ;This program is free software; you can redistribute it and/or modify
     9 ;it under the terms of the GNU General Public License as published by
     10 ;the Free Software Foundation; either version 2 of the License, or
     11 ;(at your option) any later version.
     12 ;
     13 ;This program is distributed in the hope that it will be useful,
     14 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     15 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     16 ;GNU General Public License for more details.
     17 ;
     18 ;You should have received a copy of the GNU General Public License along
     19 ;with this program; if not, write to the Free Software Foundation, Inc.,
     20 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     21 ;
    322 Q
    423 ;
    … …  
    4362 . S DGMST="0^U"
    4463 S DGIEN=""
    45  S DGIEN=+$P($Q(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1),",",5)
     64 ;
     65 ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
     66 ;
     67 ;S DGIEN=+$P($Q(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1),",",5)
     68 S DGIEN=+$P($$Q^VWUTIL($NA(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN)),-1),",",5)
     69 ;
     70 ;END CHANGE
    4671 ;
    4772 ; Check for valid ien, if entry missing, return Unknown
    … …  
    130155NEWQ Q $G(DGRSLT)
    131156 ;
    132 DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in. 
     157DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in.
    133158 ; This call is not to be used except from inside the DG MST List
    134  ; Manager interface. 
     159 ; Manager interface.
    135160 ;
    136161 ; Input
    … …  
    199224 ;
    200225DATE(DFN,DGDT) ;Determine 'current' MST date
    201  ; 
     226 ;
    202227 ;  Input
    203228 ;    DFN  - Patient's DFN

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

    r628 r636  
    1 DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ; 8/13/04 8:31am
    2  ;;5.3;Registration;**33,45,54,335,358,401,436,445,564**;Aug 13, 1993
     1DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ;11/5/06  20:29
     2 ;;5.3;Registration;**33,45,54,335,358,401,436,445,564,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319AUTO(DFN,AUTOEX) ;
    420 ; Returns 1 if Exempt from CP w/o needing MT/CP information
    … …  
    6985THRESHQT Q
    7086DISPMAS(DFN) ; Displays Co
     87 ;New EHR code    ;DAOU/JLG 2/4/05
     88 ;not relevant to Agency EHR
     89 Q:$G(DUZ("AG"))="E"
     90 ;End EHR modifications
    7191 N DGCPS,DGEX,Y,AUTOEX
    7292 S DGEX=$$AUTO(DFN,.AUTOEX)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD.m

    r628 r636  
    1 DGMTXD ; GENERATED FROM 'DGMT ENTER/EDIT DEPENDENTS' INPUT TEMPLATE(#468), FILE 408.22;08/13/05
     1DGMTXD ; GENERATED FROM 'DGMT ENTER/EDIT DEPENDENTS' INPUT TEMPLATE(#468), FILE 408.22;12/18/05
    22 D DE G BEGIN
    33DE S DIE="^DGMT(408.22,",DIC=DIE,DP=408.22,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGMT(408.22,DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD1.m

    r628 r636  
    1 DGMTXD1 ; ;08/13/05
     1DGMTXD1 ; ;12/18/05
    22 S X=DE(25),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.11,1,1,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(408.22,.11,1,1,2.4)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD2.m

    r628 r636  
    1 DGMTXD2 ; ;08/13/05
     1DGMTXD2 ; ;12/18/05
    22 S X=DG(DQ),DIC=DIE
    33 X ^DD(408.22,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(408.22,.11,1,1,1.4)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD3.m

    r628 r636  
    1 DGMTXD3 ; ;08/13/05
     1DGMTXD3 ; ;12/18/05
    22 S X=DE(27),DIC=DIE
    33 I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)="",$P(^(0),U,11) D INC^DGMTDD2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD4.m

    r628 r636  
    1 DGMTXD4 ; ;08/13/05
     1DGMTXD4 ; ;12/18/05
    22 S X=DG(DQ),DIC=DIE
    33 I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)=0,$P(^(0),U,11) D INC^DGMTDD2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXE.m

    r628 r636  
    1 DGMTXE ; GENERATED FROM 'DGMT ENTER/EDIT EXPENSES' INPUT TEMPLATE(#474), FILE 408.21;08/13/05
     1DGMTXE ; GENERATED FROM 'DGMT ENTER/EDIT EXPENSES' INPUT TEMPLATE(#474), FILE 408.21;12/18/05
    22 D DE G BEGIN
    33DE S DIE="^DGMT(408.21,",DIC=DIE,DP=408.21,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGMT(408.21,DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX1.m

    r628 r636  
    1 DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 11/22/06
     1DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 11/06/06
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX11.m

    r628 r636  
    1 DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 11/22/06
     1DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 11/06/06
    22 ;
    33 S DIKZK=2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX12.m

    r628 r636  
    1 DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 11/22/06
     1DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 11/06/06
    22 ;
    33 S DIKZK=1

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX2.m

    r628 r636  
    1 DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 11/22/06
     1DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 11/06/06
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX21.m

    r628 r636  
    1 DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 11/22/06
     1DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 11/06/06
    22 ;
    33 S DIKZK=2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX22.m

    r628 r636  
    1 DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 11/22/06
     1DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 11/06/06
    22 ;
    33 S DIKZK=1

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX3.m

    r628 r636  
    1 DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 11/22/06
     1DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 12/25/06
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX31.m

    r628 r636  
    1 DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 11/22/06
     1DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 12/25/06
    22 ;
    33 S DIKZK=2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX32.m

    r628 r636  
    1 DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 11/22/06
     1DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 12/25/06
    22 ;
    33 S DIKZK=1

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

    r628 r636  
    1 DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
    2  ;;5.3;Registration;**425,554,650**;Aug 13, 1993;Build 3
     1DGPFUT ;ALB/RPM - PRF UTILITIES ;7:46 PM  30 Jan 2008
     2 ;;5.3;Registration;**425,554,650,VWEHR1**;WorldVistA 30-Jan-08
     3 ;
     4 ;Modified from FOIA VISTA,
     5 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     6 ;General Public License See attached copy of the License.
     7 ;
     8 ;This program is free software; you can redistribute it and/or modify
     9 ;it under the terms of the GNU General Public License as published by
     10 ;the Free Software Foundation; either version 2 of the License, or
     11 ;(at your option) any later version.
     12 ;
     13 ;This program is distributed in the hope that it will be useful,
     14 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     15 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     16 ;GNU General Public License for more details.
     17 ;
     18 ;You should have received a copy of the GNU General Public License along
     19 ;with this program; if not, write to the Free Software Foundation, Inc.,
     20 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    321 ;
    422 Q   ;no direct entry
    523 ;
    6 ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS)   ;wrap FileMan Classic Reader call
     24ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
    725 ;
    826 ;  Input
    … …  
    175193 ;This function verifies that a given patient has a valid national
    176194 ;Integration Control Number.
    177  ; 
     195 ;
    178196 ;  Supported DBIA #2701:  The supported DBIA is used to access MPI
    179197 ;                         APIs to retrieve ICN and determine if ICN
    … …  
    207225 ;TREATED value immediately prior to the date for the treating facility
    208226 ;passed as the second parameter.  The most recent treating facility
    209  ;will be returned when the second parameter is missing, null, or zero. 
     227 ;will be returned when the second parameter is missing, null, or zero.
    210228 ;
    211229 ;  Input:
    … …  
    237255 . ;find entry for previous treating facility
    238256 . S DGNAM="DGDARR"
    239  . S DGARR=$QUERY(@DGNAM@(""),-1)
     257 . ;
     258 . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
     259 . ;
     260 . ;S DGARR=$QUERY(@DGNAM@(""),-1)
     261 . S DGARR=$$Q^VWUTIL($NA(@DGNAM@("")),-1)
     262 . ;
     263 . ;END CHANGE
     264 . ;
    240265 . I DGLTF,DGARR]"" D
    241266 . . I $QS(DGARR,2)'=DGLTF D
    242  . . . F  S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
    243  . . S DGARR=$QUERY(@DGARR,-1)
     267 . . . ;
     268 . . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
     269 . . . ;
     270 . . . ;F  S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
     271 . . . F  S DGARR=$$Q^VWUTIL($NA(@DGARR),-1) Q:+$QS(DGARR,2)=DGLTF
     272 . . . ;
     273 . . . ;END CHANGE
     274 . . . ;
     275 . . ;
     276 . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
     277 . . ;
     278 . . ;S DGARR=$QUERY(@DGARR,-1)
     279 . . S DGARR=$$Q^VWUTIL($NA(@DGARR),-1)
     280 . . ;
     281 . . ;END CHANGE
     282 . . ;
    244283 ;
    245284 Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX6.m

    r628 r636  
    1 DGPMX6 ; GENERATED FROM 'DGPM SPECIALTY TRANSFER' INPUT TEMPLATE(#451), FILE 405;11/22/06
     1DGPMX6 ; GENERATED FROM 'DGPM SPECIALTY TRANSFER' INPUT TEMPLATE(#451), FILE 405;11/06/06
    22 D DE G BEGIN
    33DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX61.m

    r628 r636  
    1 DGPMX61 ; ;11/22/06
     1DGPMX61 ; ;11/06/06
    22 S X=DE(14),DIC=DIE
    33 S DGPMDDF=9 D ^DGPMDD2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX62.m

    r628 r636  
    1 DGPMX62 ; ;11/22/06
     1DGPMX62 ; ;11/06/06
    22 S X=DG(DQ),DIC=DIE
    33 S DGPMDDF=9 D ^DGPMDD1

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX63.m

    r628 r636  
    1 DGPMX63 ; ;11/22/06
     1DGPMX63 ; ;11/06/06
    22 S X=DE(16),DIC=DIE
    33 S DGPMDDF=8,DGPMDDT=0 D ^DGPMDDCN

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX64.m

    r628 r636  
    1 DGPMX64 ; ;11/22/06
     1DGPMX64 ; ;11/06/06
    22 S X=DG(DQ),DIC=DIE
    33 S DGPMDDF=8,DGPMDDT=1 D ^DGPMDDCN

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX65.m

    r628 r636  
    1 DGPMX65 ; ;11/22/06
     1DGPMX65 ; ;11/06/06
    22 S X=DE(17),DIC=DIE
    33 S DGPMDDF=19,DGPMDDT=0 D ^DGPMDDCN

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX66.m

    r628 r636  
    1 DGPMX66 ; ;11/22/06
     1DGPMX66 ; ;11/06/06
    22 S X=DG(DQ),DIC=DIE
    33 S DGPMDDF=19,DGPMDDT=1 D ^DGPMDDCN

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX67.m

    r628 r636  
    1 DGPMX67 ; ;11/22/06
     1DGPMX67 ; ;11/06/06
    22 D DE G BEGIN
    33DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX.m

    r628 r636  
    1 DGPMXX ; DRIVER FOR COMPILED XREFS FOR FILE #405 ; 11/22/06
     1DGPMXX ; DRIVER FOR COMPILED XREFS FOR FILE #405 ; 11/06/06
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX1.m

    r628 r636  
    1 DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 11/22/06
     1DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 11/06/06
    22 ;
    33 S DIKZK=2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX2.m

    r628 r636  
    1 DGPMXX2 ; COMPILED XREF FOR FILE #405 ; 11/22/06
     1DGPMXX2 ; COMPILED XREF FOR FILE #405 ; 11/06/06
    22 ;
    33 S DIKZK=1

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

    r628 r636  
    11DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 2/19/04 9:33am
    2  ;;5.3;Registration;**114,115,397,510,517,478,683,775**;Aug 13, 1993;Build 3
     2 ;;5.3;Registration;**114,115,397,510,517,478,683**;Aug 13, 1993
    33 ;
    44WR ;
    … …  
    5959 ;change made to allow release of 470, before grouper released to vamc's
    6060 ;  patch 115
    61  ;DGDAT = effective date of DRG used in DGPTICD (468=CMS-DRG,998=MS-DRG)
    62  I DRG=469,(+$G(DGDAT)<3071001)  W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
    63  I DRG=998 W !!,*7,"Unable to release DRG ",DRG,".  Please verify data entered.",*7 D HANG^DGPTUTL G EN1
     61 I DRG=469 W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
    6462 I $D(DGCST),'DGCST D CEN G EN1:'DGCST
    6563 I '$P(^DGPT(PTF,0),"^",4) W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO

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

    r628 r636  
    1 DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 7/31/07 11:19am
    2  ;;5.3;Registration;**517,760**;Aug 13, 1993;Build 11
     1DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 1/15/04 8:23am
     2 ;;5.3;Registration;**517**;Aug 13, 1993
    33 ;
    44A 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(")=""
    … …  
    5252 ;
    5353KDGPT ; -- kill DGPT rec ; input DGPTIFN := ifn
    54  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
     54 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
     55 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
    5556 I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT RECORDS." H 2 K FLAG Q
    5657 D ^DIK K DA,DIK,I,FLAG

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

    r628 r636  
    1 DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 12/18/07 11:37am
    2  ;;5.3;Registration;**114,195,397,510,565,775**;Aug 13, 1993;Build 3
     1DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 11/19/03 11:37am
     2 ;;5.3;Registration;**114,195,397,510,565**;Aug 13, 1993
    33 ;;ADL;Update for CSV Project;;Mar 26, 2003
    44 ;
    … …  
    2626 . W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
    2727 D PRN2^DGPTFM8:DG300]""
    28  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
    29  . N DXD,DGDX
    30  . S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$P(M1,U,10)),DGDS=0
    31  . F  S DGDS=$O(DGDX(DGDS)) Q:'+DGDS  Q:DGDX(DGDS)=" "  W !,DGDX(DGDS)
     28 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)
    3229JUMP K DG300 F I=$Y:1:21 W !
    3330X S DGNUM=$S($D(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS") G 501^DGPTFJC:DGST

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

    r628 r636  
    11DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ; 2/19/02 3:08pm
    2  ;;5.3;Registration;**375,441,510,559,599,606,775**;Aug 13, 1993;Build 3
     2 ;;5.3;Registration;**375,441,510,559,599,606**;Aug 13, 1993
    33 ;variables to pass in:
    44 ;  DGDX <- format: DX CODE1^DX CODE2^DX CODE3^...                      (REQUIRED)
    … …  
    4949 ;
    5050PRT ;print DRG and national HCFA values
    51  I (ICDDATE<3071001)&(DRG=468!(DRG=469)!(DRG=470)) W *7
    52  I DRG=998!(DRG=999) W *7
     51 I DRG=468!(DRG=469)!(DRG=470) W *7
    5352 S Y=ICDDATE D DD^%DT ; Y=external representation of effective date
    5453 W !!?9,"Effective Date:","  ",Y

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

    r628 r636  
    11DGPTR1 ;ALB/MTC - PTF VERIFICATION ; 12/14/06 10:31am
    2  ;;5.3;Registration;**58,247,338,342,423,415,565,678,696,729,781**;Aug 13, 1993;Build 1
     2 ;;5.3;Registration;**58,247,338,342,423,415,565,678,696,729**;Aug 13, 1993;Build 59
    33START 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
    44 I T=70 S ERR=$P($T(T701),";;",2,999),W=$P($T(701),";;",2,999),F=72 D L
    … …  
    2626T60 ;;1:DATE OF PROCEDURE^2:LOSING BD SEC^3:DIALYSIS TYPE^4:NUMBER OF TREATMENTS^5:PROCEDURE CODE
    2727 ;
    28 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)
     28LOGIC ;;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)))
    2929 ;
    30  ; ; edit check# ; edit field ; # x check preformed ; display error name #
     30 ; edit check# ; edit field ; # x check preformed ; display error name #
    313110 ;;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
    3232 ;
    … …  
    3535701 ;;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
    3636 ;
    37 50 ;;1;1;10;1^1;;6;2^16;3;2;3^1;4;3;4^1;5;3;5^6;;1;6^11;7;3;7^6;;32;7^6;;9;8^14;;6;9^14;;2;10^6;;1;11^4;;1;16^4;;1;17^12;;1;18^4;;3;18^4;;1;19^4;;4;20^4;;1;21^5;;3;22^5;;1;23^5;;1;24
     3750 ;;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
    3838 ;
    393953 ;;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;

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX1.m

    r628 r636  
    1 DGPTX1 ; GENERATED FROM 'DG101' INPUT TEMPLATE(#426), FILE 45;09/04/07
     1DGPTX1 ; GENERATED FROM 'DG101' INPUT TEMPLATE(#426), FILE 45;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX11.m

    r628 r636  
    1 DGPTX11 ; ;09/04/07
     1DGPTX11 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX110.m

    r628 r636  
    1 DGPTX110 ; ;01/12/06
     1DGPTX110 ; ;04/03/06
    22 S X=DE(12),DIC=DIE
    33 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)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX111.m

    r628 r636  
    1 DGPTX111 ; ;01/12/06
     1DGPTX111 ; ;04/03/06
    22 S X=DG(DQ),DIC=DIE
    33 ;

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX112.m

    r628 r636  
    1 DGPTX112 ; ;01/12/06
     1DGPTX112 ; ;04/03/06
    22 S X=DE(13),DIC=DIE
    33 D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX113.m

    r628 r636  
    1 DGPTX113 ; ;01/12/06
     1DGPTX113 ; ;04/03/06
    22 S X=DG(DQ),DIC=DIE
    33 D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX114.m

    r628 r636  
    1 DGPTX114 ; ;01/12/06
     1DGPTX114 ; ;04/03/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX12.m

    r628 r636  
    1 DGPTX12 ; ;09/04/07
     1DGPTX12 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX13.m

    r628 r636  
    1 DGPTX13 ; ;09/04/07
     1DGPTX13 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(D0,.06,",DIC=DIE,DP=2.06,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.06,DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX14.m

    r628 r636  
    1 DGPTX14 ; ;09/04/07
     1DGPTX14 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(D0,.02,",DIC=DIE,DP=2.02,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.02,DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX15.m

    r628 r636  
    1 DGPTX15 ; ;09/04/07
     1DGPTX15 ; ;12/27/07
    22 S X=DE(14),DIC=DIE
    33 ;

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX16.m

    r628 r636  
    1 DGPTX16 ; ;09/04/07
     1DGPTX16 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 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)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX17.m

    r628 r636  
    1 DGPTX17 ; ;09/04/07
     1DGPTX17 ; ;12/27/07
    22 S X=DE(16),DIC=DIE
    33 D AUTOUPD^DGENA2(DA)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX18.m

    r628 r636  
    1 DGPTX18 ; ;09/04/07
     1DGPTX18 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 D AUTOUPD^DGENA2(DA)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX19.m

    r628 r636  
    1 DGPTX19 ; ;09/04/07
     1DGPTX19 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    … …  
    8080 S X=DG(DQ),DIC=DIE
    8181 D EVENT^IVMPLOG(DA)
    82 C1F1 N X,X1,X2 S DIXR=627 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
     82C1F1 N X,X1,X2 S DIXR=646 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
    8383 D
    8484 . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX4.m

    r628 r636  
    1 DGPTX4 ; GENERATED FROM 'DG401' INPUT TEMPLATE(#428), FILE 45;12/12/07
     1DGPTX4 ; GENERATED FROM 'DG401' INPUT TEMPLATE(#428), FILE 45;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX41.m

    r628 r636  
    1 DGPTX41 ; ;12/12/07
     1DGPTX41 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""S"",",DIC=DIE,DP=45.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"S",DA,""))=""
    … …  
    6969C5S S X="" G:DG(DQ)=X C5F1 K DB
    7070C5F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    71  F DIXR=422,423,424,425,426 S DIEZRXR(45.01,DIXR)=""
     71 F DIXR=437,438,439,440,441 S DIEZRXR(45.01,DIXR)=""
    7272 Q
    7373X5 S %DT="ETX" D ^%DT S X=+Y K:Y<1 X I $D(X) X $S(X<$P(^DGPT(DA(1),0),U,2):"W !,""Not before admission"" K X",X>($S($D(^(70)):$S(+^(70):+^(70),1:9999999),1:9999999)):"W !,""Not after discharge"" K X",1:"")
    … …  
    115115 S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
    116116C15F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    117  F DIXR=422 S DIEZRXR(45.01,DIXR)=""
     117 F DIXR=437 S DIEZRXR(45.01,DIXR)=""
    118118 Q
    119119X15 S DIC("S")="S DGI=8,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    141141 S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
    142142C20F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    143  F DIXR=423 S DIEZRXR(45.01,DIXR)=""
     143 F DIXR=438 S DIEZRXR(45.01,DIXR)=""
    144144 Q
    145145X20 S DIC("S")="S DGI=9,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    165165 D ^DGPTX43
    166166C25F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    167  F DIXR=424 S DIEZRXR(45.01,DIXR)=""
     167 F DIXR=439 S DIEZRXR(45.01,DIXR)=""
    168168 Q
    169169X25 S DIC("S")="S DGI=10,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX42.m

    r628 r636  
    1 DGPTX42 ; ;12/12/07
     1DGPTX42 ; ;12/27/07
    22 S X=DE(25),DIC=DIE
    33 K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX43.m

    r628 r636  
    1 DGPTX43 ; ;12/12/07
     1DGPTX43 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX44.m

    r628 r636  
    1 DGPTX44 ; ;12/12/07
     1DGPTX44 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""S"",",DIC=DIE,DP=45.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"S",DA,""))=""
    … …  
    6262 S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
    6363C1F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    64  F DIXR=425 S DIEZRXR(45.01,DIXR)=""
     64 F DIXR=440 S DIEZRXR(45.01,DIXR)=""
    6565 Q
    6666X1 S DIC("S")="S DGI=11,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    8888 S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
    8989C6F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    90  F DIXR=426 S DIEZRXR(45.01,DIXR)=""
     90 F DIXR=441 S DIEZRXR(45.01,DIXR)=""
    9191 Q
    9292X6 S DIC("S")="S DGI=12,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX45.m

    r628 r636  
    1 DGPTX45 ; ;12/12/07
     1DGPTX45 ; ;12/27/07
    22 ;;
    3 1 N X,X1,X2 S DIXR=422 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=437 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 I $G(X(1))]"",$G(X(2))]"" D
    55 . D KDGPT0^DGPTDDCR(.X,.DA,"S",1)
    … …  
    1212 S X=$G(X(1))
    1313 Q
    14 2 N X,X1,X2 S DIXR=423 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     142 N X,X1,X2 S DIXR=438 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    1515 I $G(X(1))]"",$G(X(2))]"" D
    1616 . D KDGPT0^DGPTDDCR(.X,.DA,"S",2)
    … …  
    2323 S X=$G(X(1))
    2424 Q
    25 3 N X,X1,X2 S DIXR=424 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
     253 N X,X1,X2 S DIXR=439 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
    2626 I $G(X(1))]"",$G(X(2))]"" D
    2727 . D KDGPT0^DGPTDDCR(.X,.DA,"S",3)
    … …  
    3434 S X=$G(X(1))
    3535 Q
    36 4 N X,X1,X2 S DIXR=425 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
     364 N X,X1,X2 S DIXR=440 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
    3737 I $G(X(1))]"",$G(X(2))]"" D
    3838 . D KDGPT0^DGPTDDCR(.X,.DA,"S",4)
    … …  
    4545 S X=$G(X(1))
    4646 Q
    47 5 N X,X1,X2 S DIXR=426 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
     475 N X,X1,X2 S DIXR=441 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
    4848 I $G(X(1))]"",$G(X(2))]"" D
    4949 . D KDGPT0^DGPTDDCR(.X,.DA,"S",5)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX5.m

    r628 r636  
    1 DGPTX5 ; GENERATED FROM 'DG501' INPUT TEMPLATE(#430), FILE 45;09/05/07
     1DGPTX5 ; GENERATED FROM 'DG501' INPUT TEMPLATE(#430), FILE 45;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX51.m

    r628 r636  
    1 DGPTX51 ; ;09/05/07
     1DGPTX51 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
    … …  
    128128 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    129129C22F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    130  F DIXR=447 S DIEZRXR(45.02,DIXR)=""
     130 F DIXR=462 S DIEZRXR(45.02,DIXR)=""
    131131 Q
    132132X22 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=5 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    158158 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    159159C27F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    160  F DIXR=448 S DIEZRXR(45.02,DIXR)=""
     160 F DIXR=463 S DIEZRXR(45.02,DIXR)=""
    161161 Q
    162162X27 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=6 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX52.m

    r628 r636  
    1 DGPTX52 ; ;09/05/07
     1DGPTX52 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
    … …  
    6666 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    6767C1F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    68  F DIXR=449 S DIEZRXR(45.02,DIXR)=""
     68 F DIXR=464 S DIEZRXR(45.02,DIXR)=""
    6969 Q
    7070X1 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    9696 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    9797C6F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    98  F DIXR=450 S DIEZRXR(45.02,DIXR)=""
     98 F DIXR=465 S DIEZRXR(45.02,DIXR)=""
    9999 Q
    100100X6 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    126126 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    127127C11F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    128  F DIXR=451 S DIEZRXR(45.02,DIXR)=""
     128 F DIXR=466 S DIEZRXR(45.02,DIXR)=""
    129129 Q
    130130X11 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX53.m

    r628 r636  
    1 DGPTX53 ; ;09/05/07
     1DGPTX53 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX54.m

    r628 r636  
    1 DGPTX54 ; ;09/05/07
     1DGPTX54 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX55.m

    r628 r636  
    1 DGPTX55 ; ;09/05/07
     1DGPTX55 ; ;12/27/07
    22 ;;
    3 1 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=462 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 I $G(X(1))]"",$G(X(2))]"" D
    55 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
    … …  
    1212 S X=$G(X(1))
    1313 Q
    14 2 N X,X1,X2 S DIXR=448 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     142 N X,X1,X2 S DIXR=463 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    1515 I $G(X(1))]"",$G(X(2))]"" D
    1616 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
    … …  
    2323 S X=$G(X(1))
    2424 Q
    25 3 N X,X1,X2 S DIXR=449 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
     253 N X,X1,X2 S DIXR=464 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
    2626 I $G(X(1))]"",$G(X(2))]"" D
    2727 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
    … …  
    3434 S X=$G(X(1))
    3535 Q
    36 4 N X,X1,X2 S DIXR=450 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
     364 N X,X1,X2 S DIXR=465 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
    3737 I $G(X(1))]"",$G(X(2))]"" D
    3838 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
    … …  
    4545 S X=$G(X(1))
    4646 Q
    47 5 N X,X1,X2 S DIXR=451 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
     475 N X,X1,X2 S DIXR=466 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
    4848 I $G(X(1))]"",$G(X(2))]"" D
    4949 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX7.m

    r628 r636  
    1 DGPTX7 ; GENERATED FROM 'DG701' INPUT TEMPLATE(#432), FILE 45;02/13/06
     1DGPTX7 ; GENERATED FROM 'DG701' INPUT TEMPLATE(#432), FILE 45;04/03/06
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
    … …  
    7373 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    7474C4F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    75  F DIXR=432 S DIEZRXR(45,DIXR)=""
     75 F DIXR=447 S DIEZRXR(45,DIXR)=""
    7676 Q
    7777X4 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=1 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    101101 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    102102C11F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    103  F DIXR=434 S DIEZRXR(45,DIXR)=""
     103 F DIXR=449 S DIEZRXR(45,DIXR)=""
    104104 Q
    105105X11 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=2 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    128128 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    129129C17F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    130  F DIXR=435 S DIEZRXR(45,DIXR)=""
     130 F DIXR=450 S DIEZRXR(45,DIXR)=""
    131131 Q
    132132X17 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=3 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    153153 D ^DGPTX72
    154154C23F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    155  F DIXR=436 S DIEZRXR(45,DIXR)=""
     155 F DIXR=451 S DIEZRXR(45,DIXR)=""
    156156 Q
    157157X23 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=4 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX71.m

    r628 r636  
    1 DGPTX71 ; ;02/13/06
     1DGPTX71 ; ;04/03/06
    22 S X=DE(23),DIC=DIE
    33 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX72.m

    r628 r636  
    1 DGPTX72 ; ;02/13/06
     1DGPTX72 ; ;04/03/06
    22 S X=DG(DQ),DIC=DIE
    33 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX73.m

    r628 r636  
    1 DGPTX73 ; ;02/13/06
     1DGPTX73 ; ;04/03/06
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
    … …  
    6161 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    6262C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    63  F DIXR=437 S DIEZRXR(45,DIXR)=""
     63 F DIXR=452 S DIEZRXR(45,DIXR)=""
    6464 Q
    6565X1 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=5 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    8989 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    9090C8F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    91  F DIXR=438 S DIEZRXR(45,DIXR)=""
     91 F DIXR=453 S DIEZRXR(45,DIXR)=""
    9292 Q
    9393X8 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=6 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    116116 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    117117C14F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    118  F DIXR=439 S DIEZRXR(45,DIXR)=""
     118 F DIXR=454 S DIEZRXR(45,DIXR)=""
    119119 Q
    120120X14 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=7 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    143143 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    144144C20F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    145  F DIXR=440 S DIEZRXR(45,DIXR)=""
     145 F DIXR=455 S DIEZRXR(45,DIXR)=""
    146146 Q
    147147X20 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=8 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX74.m

    r628 r636  
    1 DGPTX74 ; ;02/13/06
     1DGPTX74 ; ;04/03/06
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
    … …  
    6262 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    6363C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    64  F DIXR=441 S DIEZRXR(45,DIXR)=""
     64 F DIXR=456 S DIEZRXR(45,DIXR)=""
    6565 Q
    6666X1 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=9 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    8888 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    8989C6F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    90  F DIXR=442 S DIEZRXR(45,DIXR)=""
     90 F DIXR=457 S DIEZRXR(45,DIXR)=""
    9191 Q
    9292X6 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=10 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    114114 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    115115C11F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    116  F DIXR=443 S DIEZRXR(45,DIXR)=""
     116 F DIXR=458 S DIEZRXR(45,DIXR)=""
    117117 Q
    118118X11 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=11 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    140140 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
    141141C16F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    142  F DIXR=444 S DIEZRXR(45,DIXR)=""
     142 F DIXR=459 S DIEZRXR(45,DIXR)=""
    143143 Q
    144144X16 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=12 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    164164 D ^DGPTX76
    165165C21F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    166  F DIXR=445 S DIEZRXR(45,DIXR)=""
     166 F DIXR=460 S DIEZRXR(45,DIXR)=""
    167167 Q
    168168X21 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=13 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX75.m

    r628 r636  
    1 DGPTX75 ; ;02/13/06
     1DGPTX75 ; ;04/03/06
    22 S X=DE(21),DIC=DIE
    33 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX76.m

    r628 r636  
    1 DGPTX76 ; ;02/13/06
     1DGPTX76 ; ;04/03/06
    22 S X=DG(DQ),DIC=DIE
    33 X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX77.m

    r628 r636  
    1 DGPTX77 ; ;02/13/06
     1DGPTX77 ; ;04/03/06
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX78.m

    r628 r636  
    1 DGPTX78 ; ;02/13/06
     1DGPTX78 ; ;04/03/06
    22 ;;
    3 1 N X,X1,X2 S DIXR=432 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    55 . D KDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
    … …  
    1515 S X=$G(X(1))
    1616 Q
    17 2 N X,X1,X2 S DIXR=434 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     172 N X,X1,X2 S DIXR=449 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    1818 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    1919 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
    … …  
    2929 S X=$G(X(1))
    3030 Q
    31 3 N X,X1,X2 S DIXR=435 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
     313 N X,X1,X2 S DIXR=450 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
    3232 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    3333 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
    … …  
    4343 S X=$G(X(1))
    4444 Q
    45 4 N X,X1,X2 S DIXR=436 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
     454 N X,X1,X2 S DIXR=451 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
    4646 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    4747 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
    … …  
    5757 S X=$G(X(1))
    5858 Q
    59 5 N X,X1,X2 S DIXR=437 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
     595 N X,X1,X2 S DIXR=452 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
    6060 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    6161 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
    … …  
    7171 S X=$G(X(1))
    7272 Q
    73 6 N X,X1,X2 S DIXR=438 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
     736 N X,X1,X2 S DIXR=453 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
    7474 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    7575 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
    … …  
    8585 S X=$G(X(1))
    8686 Q
    87 7 N X,X1,X2 S DIXR=439 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
     877 N X,X1,X2 S DIXR=454 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
    8888 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    8989 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
    … …  
    9999 S X=$G(X(1))
    100100 Q
    101 8 N X,X1,X2 S DIXR=440 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
     1018 N X,X1,X2 S DIXR=455 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
    102102 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    103103 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD7")
    … …  
    113113 S X=$G(X(1))
    114114 Q
    115 9 N X,X1,X2 S DIXR=441 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
     1159 N X,X1,X2 S DIXR=456 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
    116116 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    117117 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD8")

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX79.m

    r628 r636  
    1 DGPTX79 ; ;02/13/06
     1DGPTX79 ; ;04/03/06
    22 ;;
    3 1 N X,X1,X2 S DIXR=442 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=457 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    55 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
    … …  
    1515 S X=$G(X(1))
    1616 Q
    17 2 N X,X1,X2 S DIXR=443 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     172 N X,X1,X2 S DIXR=458 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    1818 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    1919 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
    … …  
    2929 S X=$G(X(1))
    3030 Q
    31 3 N X,X1,X2 S DIXR=444 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
     313 N X,X1,X2 S DIXR=459 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
    3232 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    3333 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD11")
    … …  
    4343 S X=$G(X(1))
    4444 Q
    45 4 N X,X1,X2 S DIXR=445 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
     454 N X,X1,X2 S DIXR=460 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
    4646 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    4747 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD12")

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX8.m

    r628 r636  
    1 DGPTX8 ; GENERATED FROM 'DG801' INPUT TEMPLATE(#1664), FILE 46.1;09/05/07
     1DGPTX8 ; GENERATED FROM 'DG801' INPUT TEMPLATE(#1664), FILE 46.1;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGICD9(46.1,",DIC=DIE,DP=46.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGICD9(46.1,DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX81.m

    r628 r636  
    1 DGPTX81 ; ;09/05/07
     1DGPTX81 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGICD9(46.1,",DIC=DIE,DP=46.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGICD9(46.1,DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC.m

    r628 r636  
    1 DGPTXC ; GENERATED FROM 'DG PTF CREATE PTF ENTRY' INPUT TEMPLATE(#443), FILE 45;12/28/04
     1DGPTXC ; GENERATED FROM 'DG PTF CREATE PTF ENTRY' INPUT TEMPLATE(#443), FILE 45;04/07/05
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
    … …  
    7878 I $P(^DGPT(DA,0),U,4),$P(^(0),U) S ^DGPT("AFEE",$P(^DGPT(DA,0),U),$E(X,1,30),DA)=""
    7979C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    80  F DIXR=432,433,434,435,436,437,438,439,440,441,442,443,444,445,446 S DIEZRXR(45,DIXR)=""
     80 F DIXR=447,448,449,450,451,452,453,454,455,456,457,458,459,460,461 S DIEZRXR(45,DIXR)=""
    8181 Q
    8282X1 Q
    … …  
    133133C5S S X="" G:DG(DQ)=X C5F1 K DB
    134134C5F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    135  F DIXR=432,433,434,435,436,437,438,439,440,441,442,443,444,445,446 S DIEZRXR(45,DIXR)=""
     135 F DIXR=447,448,449,450,451,452,453,454,455,456,457,458,459,460,461 S DIEZRXR(45,DIXR)=""
    136136 Q
    137137X5 Q

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC1.m

    r628 r636  
    1 DGPTXC1 ; ;12/28/04
     1DGPTXC1 ; ;04/07/05
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC2.m

    r628 r636  
    1 DGPTXC2 ; ;12/28/04
     1DGPTXC2 ; ;04/07/05
    22 ;;
    3 1 N X,X1,X2 S DIXR=432 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    55 . D KDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
    … …  
    1515 S X=$G(X(1))
    1616 Q
    17 2 N X,X1,X2 S DIXR=433 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     172 N X,X1,X2 S DIXR=448 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    1818 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    1919 . D KDGPT9D^DGPTDDCR(.X,.DA,"PDX")
    … …  
    2929 S X=$G(X(1))
    3030 Q
    31 3 N X,X1,X2 S DIXR=434 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
     313 N X,X1,X2 S DIXR=449 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
    3232 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    3333 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
    … …  
    4343 S X=$G(X(1))
    4444 Q
    45 4 N X,X1,X2 S DIXR=435 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
     454 N X,X1,X2 S DIXR=450 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
    4646 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    4747 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
    … …  
    5757 S X=$G(X(1))
    5858 Q
    59 5 N X,X1,X2 S DIXR=436 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
     595 N X,X1,X2 S DIXR=451 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
    6060 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    6161 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
    … …  
    7171 S X=$G(X(1))
    7272 Q
    73 6 N X,X1,X2 S DIXR=437 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
     736 N X,X1,X2 S DIXR=452 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
    7474 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    7575 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
    … …  
    8585 S X=$G(X(1))
    8686 Q
    87 7 N X,X1,X2 S DIXR=438 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
     877 N X,X1,X2 S DIXR=453 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
    8888 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    8989 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
    … …  
    9999 S X=$G(X(1))
    100100 Q
    101 8 N X,X1,X2 S DIXR=439 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
     1018 N X,X1,X2 S DIXR=454 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
    102102 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    103103 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
    … …  
    113113 S X=$G(X(1))
    114114 Q
    115 9 N X,X1,X2 S DIXR=440 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
     1159 N X,X1,X2 S DIXR=455 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
    116116 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    117117 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD7")

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC3.m

    r628 r636  
    1 DGPTXC3 ; ;12/28/04
     1DGPTXC3 ; ;04/07/05
    22 ;;
    3 1 N X,X1,X2 S DIXR=441 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=456 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    55 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD8")
    … …  
    1515 S X=$G(X(1))
    1616 Q
    17 2 N X,X1,X2 S DIXR=442 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     172 N X,X1,X2 S DIXR=457 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    1818 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    1919 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
    … …  
    2929 S X=$G(X(1))
    3030 Q
    31 3 N X,X1,X2 S DIXR=443 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
     313 N X,X1,X2 S DIXR=458 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
    3232 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    3333 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
    … …  
    4343 S X=$G(X(1))
    4444 Q
    45 4 N X,X1,X2 S DIXR=444 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
     454 N X,X1,X2 S DIXR=459 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
    4646 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    4747 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD11")
    … …  
    5757 S X=$G(X(1))
    5858 Q
    59 5 N X,X1,X2 S DIXR=445 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
     595 N X,X1,X2 S DIXR=460 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
    6060 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    6161 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD12")
    … …  
    7171 S X=$G(X(1))
    7272 Q
    73 6 N X,X1,X2 S DIXR=446 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
     736 N X,X1,X2 S DIXR=461 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
    7474 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
    7575 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD13")

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX.m

    r628 r636  
    1 DGPTXX ; DRIVER FOR COMPILED XREFS FOR FILE #45 ; 12/12/07
     1DGPTXX ; DRIVER FOR COMPILED XREFS FOR FILE #45 ; 12/27/07
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX1.m

    r628 r636  
    1 DGPTXX1 ; COMPILED XREF FOR FILE #45 ; 12/12/07
     1DGPTXX1 ; COMPILED XREF FOR FILE #45 ; 12/27/07
    22 ;
    33 S DIKZK=2
    … …  
    9898 S X=$P(DIKZ(0),U,1)
    9999 I X'="" K ^DGPT("B",$E(X,1,30),DA)
    100 CR1 S DIXR=432
     100CR1 S DIXR=447
    101101 K X
    102102 S X(1)=$P(DIKZ(0),U,1)
    … …  
    111111 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    112112 . D KDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
    113 CR2 S DIXR=433
     113CR2 S DIXR=448
    114114 K X
    115115 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    125125 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    126126 . D KDGPT9D^DGPTDDCR(.X,.DA,"PDX")
    127 CR3 S DIXR=434
     127CR3 S DIXR=449
    128128 K X
    129129 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    139139 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    140140 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
    141 CR4 S DIXR=435
     141CR4 S DIXR=450
    142142 K X
    143143 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    153153 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    154154 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
    155 CR5 S DIXR=436
     155CR5 S DIXR=451
    156156 K X
    157157 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    167167 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    168168 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
    169 CR6 S DIXR=437
     169CR6 S DIXR=452
    170170 K X
    171171 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    181181 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    182182 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
    183 CR7 S DIXR=438
     183CR7 S DIXR=453
    184184 K X
    185185 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    195195 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    196196 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
    197 CR8 S DIXR=439
     197CR8 S DIXR=454
    198198 K X
    199199 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    209209 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    210210 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
    211 CR9 S DIXR=440
     211CR9 S DIXR=455
    212212 K X
    213213 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    223223 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    224224 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD7")
    225 CR10 S DIXR=441
     225CR10 S DIXR=456
    226226 K X
    227227 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    237237 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    238238 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD8")
    239 CR11 S DIXR=442
     239CR11 S DIXR=457
    240240 K X
    241241 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    251251 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    252252 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
    253 CR12 S DIXR=443
     253CR12 S DIXR=458
    254254 K X
    255255END G ^DGPTXX2

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX10.m

    r628 r636  
    1 DGPTXX10 ; COMPILED XREF FOR FILE #45.01 ; 12/12/07
     1DGPTXX10 ; COMPILED XREF FOR FILE #45.01 ; 12/27/07
    22 ;
    33 S DA(1)=DA S DA=0
    … …  
    1818 S X=$P(DIKZ(0),U,12)
    1919 I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
    20 CR1 S DIXR=422
     20CR1 S DIXR=437
    2121 K X
    2222 S X(1)=$P(DIKZ(0),U,1)
    … …  
    2626 . K X1,X2 M X1=X,X2=X
    2727 . D SDGPT0^DGPTDDCR(.X,.DA,"S",1)
    28 CR2 S DIXR=423
     28CR2 S DIXR=438
    2929 K X
    3030 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
    … …  
    3535 . K X1,X2 M X1=X,X2=X
    3636 . D SDGPT0^DGPTDDCR(.X,.DA,"S",2)
    37 CR3 S DIXR=424
     37CR3 S DIXR=439
    3838 K X
    3939 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
    … …  
    4444 . K X1,X2 M X1=X,X2=X
    4545 . D SDGPT0^DGPTDDCR(.X,.DA,"S",3)
    46 CR4 S DIXR=425
     46CR4 S DIXR=440
    4747 K X
    4848 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
    … …  
    5353 . K X1,X2 M X1=X,X2=X
    5454 . D SDGPT0^DGPTDDCR(.X,.DA,"S",4)
    55 CR5 S DIXR=426
     55CR5 S DIXR=441
    5656 K X
    5757 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX11.m

    r628 r636  
    1 DGPTXX11 ; COMPILED XREF FOR FILE #45.02 ; 12/12/07
     1DGPTXX11 ; COMPILED XREF FOR FILE #45.02 ; 12/27/07
    22 ;
    33 S DA=0
    … …  
    6464 S X=$P(DIKZ(0),U,15)
    6565 I X'="" X ^DD(45.02,15,1,992,1)
    66 CR1 S DIXR=447
     66CR1 S DIXR=462
    6767 K X
    6868 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    7373 . K X1,X2 M X1=X,X2=X
    7474 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
    75 CR2 S DIXR=448
     75CR2 S DIXR=463
    7676 K X
    7777 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    8282 . K X1,X2 M X1=X,X2=X
    8383 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
    84 CR3 S DIXR=449
     84CR3 S DIXR=464
    8585 K X
    8686 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    9191 . K X1,X2 M X1=X,X2=X
    9292 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
    93 CR4 S DIXR=450
     93CR4 S DIXR=465
    9494 K X
    9595 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    100100 . K X1,X2 M X1=X,X2=X
    101101 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
    102 CR5 S DIXR=451
     102CR5 S DIXR=466
    103103 K X
    104104 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    109109 . K X1,X2 M X1=X,X2=X
    110110 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")
    111 CR6 S DIXR=452
     111CR6 S DIXR=467
    112112 K X
    113113 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    118118 . K X1,X2 M X1=X,X2=X
    119119 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD6")
    120 CR7 S DIXR=453
     120CR7 S DIXR=468
    121121 K X
    122122 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    127127 . K X1,X2 M X1=X,X2=X
    128128 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD7")
    129 CR8 S DIXR=454
     129CR8 S DIXR=469
    130130 K X
    131131 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    136136 . K X1,X2 M X1=X,X2=X
    137137 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD8")
    138 CR9 S DIXR=455
     138CR9 S DIXR=470
    139139 K X
    140140 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    145145 . K X1,X2 M X1=X,X2=X
    146146 . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD9")
    147 CR10 S DIXR=456
     147CR10 S DIXR=471
    148148 K X
    149149 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX12.m

    r628 r636  
    1 DGPTXX12 ; COMPILED XREF FOR FILE #45.05 ; 12/12/07
     1DGPTXX12 ; COMPILED XREF FOR FILE #45.05 ; 12/27/07
    22 ;
    33 S DA=0
    … …  
    1818 S X=$P(DIKZ(0),U,9)
    1919 I X'="" S ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)=""
    20 CR1 S DIXR=427
     20CR1 S DIXR=442
    2121 K X
    2222 S X(1)=$P(DIKZ(0),U,1)
    … …  
    2626 . K X1,X2 M X1=X,X2=X
    2727 . D SDGPT0^DGPTDDCR(.X,.DA,"P",1)
    28 CR2 S DIXR=428
     28CR2 S DIXR=443
    2929 K X
    3030 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
    … …  
    3535 . K X1,X2 M X1=X,X2=X
    3636 . D SDGPT0^DGPTDDCR(.X,.DA,"P",2)
    37 CR3 S DIXR=429
     37CR3 S DIXR=444
    3838 K X
    3939 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
    … …  
    4444 . K X1,X2 M X1=X,X2=X
    4545 . D SDGPT0^DGPTDDCR(.X,.DA,"P",3)
    46 CR4 S DIXR=430
     46CR4 S DIXR=445
    4747 K X
    4848 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
    … …  
    5353 . K X1,X2 M X1=X,X2=X
    5454 . D SDGPT0^DGPTDDCR(.X,.DA,"P",4)
    55 CR5 S DIXR=431
     55CR5 S DIXR=446
    5656 K X
    5757 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX13.m

    r628 r636  
    1 DGPTXX13 ; COMPILED XREF FOR FILE #45.0535 ; 12/12/07
     1DGPTXX13 ; COMPILED XREF FOR FILE #45.0535 ; 12/27/07
    22 ;
    33 S DA=0

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX14.m

    r628 r636  
    1 DGPTXX14 ; COMPILED XREF FOR FILE #45.06 ; 12/12/07
     1DGPTXX14 ; COMPILED XREF FOR FILE #45.06 ; 12/27/07
    22 ;
    33 S DA=0
    … …  
    1212 S X=$P(DIKZ(0),U,6)
    1313 I X'="" D ADD^AUPNVSIT
    14 CR1 S DIXR=624
     14CR1 S DIXR=200
    1515 K X
    1616 S X(1)=$P(DIKZ(0),U,1)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX2.m

    r628 r636  
    1 DGPTXX2 ; COMPILED XREF FOR FILE #45 ; 12/12/07
     1DGPTXX2 ; COMPILED XREF FOR FILE #45 ; 12/27/07
    22 ;
    33 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    1414 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    1515 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
    16 CR13 S DIXR=444
     16CR13 S DIXR=459
    1717 K X
    1818 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    2929 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    3030 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD11")
    31 CR14 S DIXR=445
     31CR14 S DIXR=460
    3232 K X
    3333 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    4444 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
    4545 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD12")
    46 CR15 S DIXR=446
     46CR15 S DIXR=461
    4747 K X
    4848 S DIKZ(0)=$G(^DGPT(DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX3.m

    r628 r636  
    1 DGPTXX3 ; COMPILED XREF FOR FILE #45.01 ; 12/12/07
     1DGPTXX3 ; COMPILED XREF FOR FILE #45.01 ; 12/27/07
    22 ;
    33 S DA(1)=DA S DA=0
    … …  
    1818 S X=$P(DIKZ(0),U,12)
    1919 I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)
    20 CR1 S DIXR=422
     20CR1 S DIXR=437
    2121 K X
    2222 S X(1)=$P(DIKZ(0),U,1)
    … …  
    2727 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    2828 . D KDGPT0^DGPTDDCR(.X,.DA,"S",1)
    29 CR2 S DIXR=423
     29CR2 S DIXR=438
    3030 K X
    3131 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
    … …  
    3737 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    3838 . D KDGPT0^DGPTDDCR(.X,.DA,"S",2)
    39 CR3 S DIXR=424
     39CR3 S DIXR=439
    4040 K X
    4141 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
    … …  
    4747 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    4848 . D KDGPT0^DGPTDDCR(.X,.DA,"S",3)
    49 CR4 S DIXR=425
     49CR4 S DIXR=440
    5050 K X
    5151 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
    … …  
    5757 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    5858 . D KDGPT0^DGPTDDCR(.X,.DA,"S",4)
    59 CR5 S DIXR=426
     59CR5 S DIXR=441
    6060 K X
    6161 S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX4.m

    r628 r636  
    1 DGPTXX4 ; COMPILED XREF FOR FILE #45.02 ; 12/12/07
     1DGPTXX4 ; COMPILED XREF FOR FILE #45.02 ; 12/27/07
    22 ;
    33 S DA=0
    … …  
    6464 S X=$P(DIKZ(0),U,15)
    6565 I X'="" X ^DD(45.02,15,1,992,2)
    66 CR1 S DIXR=447
     66CR1 S DIXR=462
    6767 K X
    6868 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    7474 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    7575 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
    76 CR2 S DIXR=448
     76CR2 S DIXR=463
    7777 K X
    7878 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    8484 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    8585 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
    86 CR3 S DIXR=449
     86CR3 S DIXR=464
    8787 K X
    8888 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    9494 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    9595 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
    96 CR4 S DIXR=450
     96CR4 S DIXR=465
    9797 K X
    9898 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    104104 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    105105 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
    106 CR5 S DIXR=451
     106CR5 S DIXR=466
    107107 K X
    108108 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    114114 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    115115 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")
    116 CR6 S DIXR=452
     116CR6 S DIXR=467
    117117 K X
    118118 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    124124 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    125125 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD6")
    126 CR7 S DIXR=453
     126CR7 S DIXR=468
    127127 K X
    128128 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    134134 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    135135 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD7")
    136 CR8 S DIXR=454
     136CR8 S DIXR=469
    137137 K X
    138138 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    144144 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    145145 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD8")
    146 CR9 S DIXR=455
     146CR9 S DIXR=470
    147147 K X
    148148 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
    … …  
    154154 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    155155 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD9")
    156 CR10 S DIXR=456
     156CR10 S DIXR=471
    157157 K X
    158158 S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX5.m

    r628 r636  
    1 DGPTXX5 ; COMPILED XREF FOR FILE #45.05 ; 12/12/07
     1DGPTXX5 ; COMPILED XREF FOR FILE #45.05 ; 12/27/07
    22 ;
    33 S DA=0
    … …  
    1818 S X=$P(DIKZ(0),U,9)
    1919 I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)
    20 CR1 S DIXR=427
     20CR1 S DIXR=442
    2121 K X
    2222 S X(1)=$P(DIKZ(0),U,1)
    … …  
    2727 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    2828 . D KDGPT0^DGPTDDCR(.X,.DA,"P",1)
    29 CR2 S DIXR=428
     29CR2 S DIXR=443
    3030 K X
    3131 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
    … …  
    3737 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    3838 . D KDGPT0^DGPTDDCR(.X,.DA,"P",2)
    39 CR3 S DIXR=429
     39CR3 S DIXR=444
    4040 K X
    4141 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
    … …  
    4747 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    4848 . D KDGPT0^DGPTDDCR(.X,.DA,"P",3)
    49 CR4 S DIXR=430
     49CR4 S DIXR=445
    5050 K X
    5151 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
    … …  
    5757 . S:$D(DIKIL) (X2,X2(1),X2(2))=""
    5858 . D KDGPT0^DGPTDDCR(.X,.DA,"P",4)
    59 CR5 S DIXR=431
     59CR5 S DIXR=446
    6060 K X
    6161 S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX6.m

    r628 r636  
    1 DGPTXX6 ; COMPILED XREF FOR FILE #45.0535 ; 12/12/07
     1DGPTXX6 ; COMPILED XREF FOR FILE #45.0535 ; 12/27/07
    22 ;
    33 S DA=0

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX7.m

    r628 r636  
    1 DGPTXX7 ; COMPILED XREF FOR FILE #45.06 ; 12/12/07
     1DGPTXX7 ; COMPILED XREF FOR FILE #45.06 ; 12/27/07
    22 ;
    33 S DA=0
    … …  
    1212 S X=$P(DIKZ(0),U,1)
    1313 I X'="" K ^DGPT(DA(1),"C","B",$E(X,1,30),DA)
    14 CR1 S DIXR=624
     14CR1 S DIXR=200
    1515 K X
    1616 S X(1)=$P(DIKZ(0),U,1)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX8.m

    r628 r636  
    1 DGPTXX8 ; COMPILED XREF FOR FILE #45 ; 12/12/07
     1DGPTXX8 ; COMPILED XREF FOR FILE #45 ; 12/27/07
    22 ;
    33 S DIKZK=1
    … …  
    9292 S X=$P(DIKZ(70),U,11)
    9393 I X'="" X ^DD(45,80,1,992,1)
    94 CR1 S DIXR=432
     94CR1 S DIXR=447
    9595 K X
    9696 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    105105 . K X1,X2 M X1=X,X2=X
    106106 . D SDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
    107 CR2 S DIXR=433
     107CR2 S DIXR=448
    108108 K X
    109109 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    118118 . K X1,X2 M X1=X,X2=X
    119119 . D SDGPT9D^DGPTDDCR(.X,.DA,"PDX")
    120 CR3 S DIXR=434
     120CR3 S DIXR=449
    121121 K X
    122122 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    131131 . K X1,X2 M X1=X,X2=X
    132132 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
    133 CR4 S DIXR=435
     133CR4 S DIXR=450
    134134 K X
    135135 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    144144 . K X1,X2 M X1=X,X2=X
    145145 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
    146 CR5 S DIXR=436
     146CR5 S DIXR=451
    147147 K X
    148148 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    157157 . K X1,X2 M X1=X,X2=X
    158158 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
    159 CR6 S DIXR=437
     159CR6 S DIXR=452
    160160 K X
    161161 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    170170 . K X1,X2 M X1=X,X2=X
    171171 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
    172 CR7 S DIXR=438
     172CR7 S DIXR=453
    173173 K X
    174174 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    183183 . K X1,X2 M X1=X,X2=X
    184184 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
    185 CR8 S DIXR=439
     185CR8 S DIXR=454
    186186 K X
    187187 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    196196 . K X1,X2 M X1=X,X2=X
    197197 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
    198 CR9 S DIXR=440
     198CR9 S DIXR=455
    199199 K X
    200200 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    209209 . K X1,X2 M X1=X,X2=X
    210210 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD7")
    211 CR10 S DIXR=441
     211CR10 S DIXR=456
    212212 K X
    213213 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    222222 . K X1,X2 M X1=X,X2=X
    223223 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD8")
    224 CR11 S DIXR=442
     224CR11 S DIXR=457
    225225 K X
    226226 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    235235 . K X1,X2 M X1=X,X2=X
    236236 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
    237 CR12 S DIXR=443
     237CR12 S DIXR=458
    238238 K X
    239239 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    249249 . K X1,X2 M X1=X,X2=X
    250250 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
    251 CR13 S DIXR=444
     251CR13 S DIXR=459
    252252 K X
    253253 S DIKZ(0)=$G(^DGPT(DA,0))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX9.m

    r628 r636  
    1 DGPTXX9 ; COMPILED XREF FOR FILE #45 ; 12/12/07
     1DGPTXX9 ; COMPILED XREF FOR FILE #45 ; 12/27/07
    22 ;
    3 CR14 S DIXR=445
     3CR14 S DIXR=460
    44 K X
    55 S DIKZ(0)=$G(^DGPT(DA,0))
    … …  
    1515 . K X1,X2 M X1=X,X2=X
    1616 . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD12")
    17 CR15 S DIXR=446
     17CR15 S DIXR=461
    1818 K X
    1919 S DIKZ(0)=$G(^DGPT(DA,0))

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

    r628 r636  
    1 DGREG ;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ; 8/24/05 1:40pm
    2  ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658**;Aug 13, 1993
     1DGREG ;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ;1/27/07  13:08
     2 ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
    311START ;
    412EN D LO^DGUTL S DGCLPR=""
    … …  
    1018 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
    1119A D ENDREG($G(DFN))
    12  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
     20 ;
     21 ; ** VOE change 1 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
     22 ;
     23 ; if not VA agency code, add DIC("DR") to default some identifiers and
     24 ; skip others also, improve readability
     25 ;
     26 ; before change:
     27 ; 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
     28 ;
     29 ; after change:
     30 W !!
     31 N Y,DGREGY S DGREGY=1 D  I DGREGY<0 G Q1
     32 . N DIC S DIC=2 ; Patient file
     33 . S DIC(0)="ALEQM" ; ask, laygo, echo, question, and multi-index
     34 . N DLAYGO S DLAYGO=2 ; override file access by user: allow laygo
     35 . I $G(DUZ("AG"))'="V" D  ;adjust identifiers asked for VOE
     36 . . S DIC("DR")=".02;.03;994;.301///N;391///VISTA OFFICE EHR;1901///N;.09"
     37 . ;
     38 . D ^DIC ; Select Patient
     39 . ;
     40 . I Y<0 S DGREGY=-1 Q
     41 . K DIC("DR")
     42 . S (DFN,DA)=+Y
     43 . S DGNEW=$P(Y,"^",3) ; new patient?
     44 . N Y D PAUSE^DG10 ; prompt user before continuing
     45 . D BEGINREG(DFN) ; lock patient record
     46 ;
     47 ; ** end of VOE change 1 **
    1348 ;
    1449 ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
    … …  
    1853 D CIRN
    1954 ;
    20  I +$G(DGNEW) D
     55 ; ** VOE change 2 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
     56 ;
     57 I $G(DGNEW) D NEW^DGRP ; execute new patient DR string
     58 ;
     59 ; send CMOR query and display results only if VA agency code
     60 ;
     61 ; before change:
     62 ; I +$G(DGNEW) D
     63 ;
     64 ; after change:
     65 I $G(DGNEW),$G(DUZ("AG"))="V" D
     66 . ;
     67 . ; end of change
     68 . ;
    2169 . ; query CMOR for Patient Record Flag Assignments if NEW patient and
    2270 . ; display results.
    2371 . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
    2472 ;
    25  D ROMQRY
     73 ; before change:
     74 ; D ROMQRY
     75 ;
     76 ; after change:
     77 I $G(DUZ("AG"))="V" D ROMQRY
     78 ;
     79 ; ** end of VOE change 2 **
    2680 ;
    2781 S (DGFC,CURR)=0
    … …  
    3084 D HINQ^DG10
    3185 I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3
    32  D REG^IVMCQ($G(DFN))  ; send financial query 
     86 ;
     87 ; ** VOE change 3 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
     88 ;
     89 ; send financial query only for VA agency code
     90 ;
     91 ; before change:
     92 ; D REG^IVMCQ($G(DFN))  ; send financial query
     93 ;
     94 ; after change:
     95 I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN)) ; send financial query
     96 ;
     97 ; ** end of VOE change 3 **
     98 ;
    3399 G A1
    34100 ;
    … …  
    62128 ;
    63129 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
     130 ;
     131 ; ** VOE change 4 of 4: DAOU/JLG 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
     132 ;
     133 ; for VOE or IHS agency codes, add the following:
     134 ; force TYPE OF CARE with ALL OTHER
     135 ;
     136 I $G(DUZ("AG"))="E"!($G(DUZ("AG"))="I") D
     137 . 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
     138 ;
     139 ; ** end of VOE change 4 **
     140 ;
    64141 D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:2 G:'$T MSG D ^DIE L -@DGNDLOCK
    65142 I $D(DTOUT) D  G Q

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

    r628 r636  
    1 DGREGAED ;ALB/DW/PHH - Address Edit API; 9/1/2005
    2  ;;5.3;Registration;**522,560,658,730**;Aug 13, 1993;Build 2
     1DGREGAED ;ALB/DW/PHH - Address Edit API; 1/5/2006  23:03 ;10/10/06  08:05
     2 ;;5.3;Registration;**522,560,658,730,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319EN(DFN,FLG) ;Entry point
    420 ;Input:
    … …  
    1127 N I,X,Y
    1228 I $G(DFN)="" Q
    13  ;I ($G(DFN)'?.N) Q
     29 I ($G(DFN)'?.N) Q
    1430 S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2))
    1531 D INPUT(.DGINPUT,DFN)
    … …  
    2945 N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,POP
    3046 S POP=0
    31  F DGN=.111,.112,.113,.1112,.131,.132,.121 Q:POP  D
     47 ;
     48 ; ** VOE change 1 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
     49 ;
     50 ; .134 is new field ALTERNATE PHONE for VOE
     51 ;
     52 ; before change:
     53 ;
     54 ; F DGN=.111,.112,.113,.1112,.131,.132,.121 Q:POP  D
     55 ;
     56 ; after change:
     57 ;
     58 F DGN=.111,.112,.113,.1112,.131,.132,.134,.121 Q:POP  D
     59 . ;
     60 . ; end change
     61 . ;
    3262 . I ($G(DGINPUT(.111))="")&((DGN=.112)!(DGN=.113)) Q
    3363 . I ($G(DGINPUT(.112))="")&(DGN=.113) Q
    … …  
    3767 .. I $G(DGR)=-1 S POP=1 Q
    3868 .. N DGM F DGM=.1112,.114,.115,.117 S DGINPUT(DGM)=$G(DGR(DGM))
     69 . ;
     70 . ; new line:
     71 . ;
     72 . I DGN=.134,$G(DUZ("AG"))'="E" Q
     73 . ;
     74 . ; ** end of VOE change 1 **
     75 . ;
    3976AGN . S DIR(0)=2_","_DGN
    4077 . S DA=DFN
    … …  
    5087 I $G(POP)=1 S DGINPUT=-1
    5188 Q
    52 COMPARE(DGINPUT,DFN) ;Display before & after address fields
     89COMPARE(DGINPUT,DFN) ;Display before & after address fields.
    5390 N DGCURR,DGN,DGCMP,DGM,DGCNTY,DGCIEN,DGST
    5491 D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121","EI","DGCURR")
    55  F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121 D
     92 ;
     93 ; ** VOE change 2 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
     94 ;
     95 ; for VOE agency code, add new ALTERNATE PHONE field (.134)
     96 ; to DGCMP("OLD") array
     97 ;
     98 ; before change:
     99 ;
     100 ; F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121 D
     101 ; . S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
     102 ;
     103 ; after change:
     104 ;
     105 I $G(DUZ("AG"))="E" D GETS^DIQ(2,DFN,.134,"EI","DGCURR")
     106 F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.134,.121 D
     107 . I $G(DUZ("AG"))'="E",DGN=.134 Q  ; skip for non-VOE
     108 . ;
     109 . ; ** end of VOE change 2 **
     110 . ;
    56111 . S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
    57112 S DGCIEN=$G(DGCURR(2,DFN_",",.117,"I"))
    … …  
    77132 .. W !,?6,"   Phone: ",?16,$P($G(DGCMP(DGM,.131)),U)
    78133 .. W !,?6,"  Office: ",?16,$P($G(DGCMP(DGM,.132)),U)
     134 .. ;
     135 .. ; ** VOE change 3 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
     136 .. ;
     137 .. ; for VOE agency code, display new ALTERNATE PHONE field (.134)
     138 .. ;
     139 .. ; insert line:
     140 .. ;
     141 .. I $G(DUZ("AG"))="E" W !,?6," Alt Phone: ",?16,$P($G(DGCMP(DGM,.134)),U)
     142 .. ;
     143 .. ; ** end of VOE change 3 **
     144 .. ;
    79145 . W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U)
    80146 . W !

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

    r628 r636  
    11DGREGAZL ;ALB/DW - ZIP LINKING UTILITY ; 5/27/04 10:54am
    2  ;;5.3;Registration;**522,560,581,730,760**;Aug 13, 1993;Build 11
     2 ;;5.3;Registration;**522,560,581,730**;Aug 13, 1993;Build 2
    33 ;
    44EN(RESULT,DFN) ;Let user edit zip+4, city, state, county based on zip-linking
    … …  
    4343 I DGZIP="" Q DGZIP
    4444 D POSTALB^XIPUTIL(DGZIP,.DGDATA)
    45   ;DG*730 - later commented out by DG*760
    46  ;I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
     45  ;DG*730
     46 I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
    4747 I $D(DGDATA("ERROR")) D  G ZAGN
    4848 . W $C(7)," ??"
    … …  
    5252 ;   ZIP - user input zip for the patient primary address
    5353 ;   DFN - Interal entry number of Patient File (#2)
    54  ; Output:RESULT=-1 (input error or timed or ^ out)
     54 ; Output:RESULT=-1 (input error or times or ^ out)
    5555 ;        or    =user input city
    5656 ;        Array index # of selected city.
    … …  
    5959 N DGCITY,DGST,DGCNTY,DGABRV,DGN,DGECH,DGSOC
    6060 N DOLDCITY,DGSAME,DGELEVEN
    61  ; DG*760 brought in DGCITI
    62  N DGCITI
    6361 S DGIND=""
    6462 D POSTALB^XIPUTIL(ZIP,.DGDATA)
    65  ;DG*730 - later commented out by DG*760
    66  ;I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
     63 ;DG*730
     64 I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
    6765 D FIELD^DID(2,.114,"N","LABEL","DGCITY")
    6866 S DGN=""
    … …  
    7169 . S DGSAME=0
    7270 . F  S DGN=$O(DGDATA(DGN)) Q:DGN=""  D
    73  .. S DGCITI=$P($G(DGDATA(DGN,"CITY")),"*",1)
    7471 .. S DGABRV=$G(DGDATA(DGN,"CITY ABBREVIATION"))
    75  .. I DOLDCITY'="",DGCITI=DOLDCITY!(DGABRV=DOLDCITY) S DGSAME=1
    76  .. ; next 4 commented out lines done by DG*760
    77  .. ;I DGABRV="" S DGABRV=$P($G(DGDATA(DGN,"CITY")),"*",1)
    78  .. ;I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
    79  .. ;I $G(DGDATA(DGN,"CITY"))["*" S:DGABRV'="" DGABRV=DGABRV_"*"
    80  .. I $G(DGDATA(DGN,"CITY"))["*" S DGCITI=DGCITI_"*"
    81  .. ;S DGECH=DGN_":"_DGABRV
    82  .. S DGECH=DGN_":"_DGCITI
     72 .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
     73 .. I DGABRV="" S DGABRV=$P($G(DGDATA(DGN,"CITY")),"*",1)
     74 .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
     75 .. I $G(DGDATA(DGN,"CITY"))["*" S:DGABRV'="" DGABRV=DGABRV_"*"
     76 .. S DGECH=DGN_":"_DGABRV
    8377 .. S DGSOC=$S($G(DGSOC)="":DGECH,1:DGSOC_";"_DGECH)
    8478 .. S DGTOT=DGN
    … …  
    111105 . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN2
    112106 . S RESULT=$G(Y)
    113  I $L($G(RESULT))>15 D
    114  . S DGN=Y
    115  . S RESULT=$G(DGDATA(DGN,"CITY ABBREVIATION"))
     107 I $L($G(RESULT))>15 S RESULT=$E(RESULT,1,15)
    116108 Q DGIND
    117109 ;

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

    r628 r636  
    1 DGRP1 ;ALB/MRL,ERC - DEMOGRAPHIC DATA ; 06/22/06
    2  ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653**;Aug 13, 1993;Build 2
     1DGRP1 ;ALB/MRL - DEMOGRAPHIC DATA ;1/8/07  09:14
     2 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;
     20 ; 2005 03 18 (VA/JT): DG*5.3*629, stop Missing Patient message based
     21 ; on questionable data in Missing Person Date fld (.153).
     22 ;
     23 ; 2005 04 25? (VA/MRY): DG*5.3*638, add Sex to IDs shown.
     24 ;
     25 ; 2005 04 27 (VA/JT): DG*5.3*649, change last $EXTRACT for Alias SSN in
     26 ; GETNCAL to 10 chars instead of 9, to preserve trailing P for pseudo-
     27 ; SSNs.
     28 ;
     29 ; 2006 04 21 (WV/TOAD, after DAOU/WCJ (2005 02 07) and
     30 ; VA/CJS (2005/12/23)): restore 6-part VOE change; space dots and
     31 ; semi-colons.
     32 ;
     33 ; 2006 05 09 (WV/TOAD): rewrite VOE change to fix bugs introduced by
     34 ; VA and VOE, and completely refactor bug-prone GETNCAL, and merge back
     35 ; into main subroutine body.
    336 ;
    437EN 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:"")
    538 I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
    639 ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'.  NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
     40 ;
     41 ; ** VOE change 1 of 3 **
     42 ;
     43 ; if EHR agency code, display Registration Date (Date Entered into
     44 ; File, .097)
     45 ;
     46 ; new lines:
     47 I $G(DUZ("AG"))="E" D
     48 . W !?58,"Reg Dt: ",$$FMTE^XLFDT($P(DGRP(0),U,16),"2D")
     49 ;
     50 ;
     51 ; show field groups 1 and 2 in two columns
     52 ;
     53 ; field groups 1 & 2 part 1: show Name, SSN, and DOB
     54 ;
     55 ;
     56 ; ** end of VOE change 1 **
     57 ;
    758 W ! S Z=1 D WW^DGRPV W "    Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
    859 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
    … …  
    1768 . . Q:$G(DGREAS)']""
    1869 . . W DGREAS
    19  D GETNCAL  ;Display name component, sex, and alias information
     70 ;
     71 ; ** VOE change 2 of 3 **
     72 ;
     73 ; eliminate unnecessary subroutine GETNCAL and merge code back into
     74 ; the main subroutine, and make the following changes:
     75 ;
     76 ; For EHR or IHS agency code, show Health Record No. (.02) for the
     77 ; current Facility from the Health Record No. multiple field
     78 ; (4101/9000001.41) of the IHS Patient file (9000001) for the current
     79 ; patient.
     80 ;
     81 ; Move Sex field over so it shows up in the same location for
     82 ; VA, IHS, and EHR, leaving a blank for where HRN can appear.
     83 ;
     84 ; Fix the VA bug in which patients having five valid aliases
     85 ; were showing "< More alias entries on file >" instead of the fifth
     86 ; alias.
     87 ;
     88 ; Refactor entire subroutine: clean original design was broken
     89 ; by patching and had become fragile and confusing; tighten variable
     90 ; scopes, use clearer names, comment.
     91 ;
     92 ; before:
     93 ;
     94 ; D GETNCAL  ;Display name component, sex, and alias information
     95 ;
     96 ; after:
     97 ;
     98 ; field groups 1 & 2 part 2: load name components
     99 ;
     100 ;
     101 N DGLABEL S DGLABEL="^ Given^Middle^Prefix^Suffix^Degree" ; labels
     102 N DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," ; Name Components fd (1.01)
     103 I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") ; Name Components file
     104 ; loads Family (Last) Name (1), Given (First) Name (2),
     105 ; Middle Name (3), Prefix (4), Suffix (5), and Degree (6)
     106 ;
     107 ;
     108 ; field groups 1 & 2 part 3: load aliases
     109 ;
     110 ;
     111 N DGCOUNT S DGCOUNT=0 ; how many aliases do we find
     112 N DGALIAS S DGALIAS=0 ; IEN of Alias subfile (1/2.01) of Patient fl (2)
     113 ;                       and array of aliases found
     114 S DGALIAS=0 F  D  Q:'DGALIAS
     115 . ;
     116 . S DGALIAS=$O(^DPT(DFN,.01,DGALIAS))
     117 . Q:'DGALIAS  ; out of alias subrecords
     118 . N DGNODE S DGNODE=$G(^DPT(DFN,.01,DGALIAS,0)) ; 0-node of subrecord
     119 . Q:'$L(DGNODE)  ; bad node
     120 . ;
     121 . S DGCOUNT=DGCOUNT+1 ; another valid alias
     122 . I DGCOUNT=6 S DGALIAS=0 Q  ; can't show > 5, need to know if 6 or >
     123 . ;
     124 . S DGALIAS(DGCOUNT)=$P(DGNODE,U) ; Alias fld (.01)
     125 . ;
     126 . N DGSSN S DGSSN=$P(DGNODE,U,2) ; Alias SSN fld (1)
     127 . I $L(DGSSN) D
     128 . . S DGSSN=" "_$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10)
     129 . . ; incl leading space to separate from alias name
     130 . . ; incl 10 chars to allow for P of pseudo-SSNs
     131 . . S $E(DGALIAS(DGCOUNT),20)=DGSSN ; truncate alias name & append SSN
     132 . ;
     133 . S DGALIAS(DGCOUNT)=$E(DGALIAS(DGCOUNT),1,32) ; truncate alias
     134 ;
     135 I DGCOUNT=0 S DGALIAS(1)="< No alias entries on file >"
     136 I DGCOUNT=6 S DGALIAS(5)="< More alias entries on file >"
     137 K DGCOUNT
     138 ;
     139 ;
     140 ; field groups 1 & 2 part 4: show 1st name component, and IDs HRN & Sex
     141 ;
     142 ;
     143 W !?5,"Family: "
     144 W $E($G(DGCOMP(20,DGCOMP,1)),1,27)
     145 ;
     146 I "EI"[$G(DUZ("AG")),$G(DUZ(2)) D
     147 . N DGNODE S DGNODE=$G(^AUPNPAT(DFN,41,DUZ(2),0)) ; get 0-node for the
     148 . ; current Facility from the Health Record No. multiple field
     149 . ; (4101/9000001.41) for DFN in the IHS Patient file (9000001)
     150 . N DGHRN S DGHRN=$P(DGNODE,U,2) ; Health Record No. (.02)
     151 . W ?42," HRN: ",DGHRN
     152 ;
     153 D
     154 . N DGSEX S DGSEX=$P(DGRP(0),U,2) ; Sex fld (.02) of Patient file (2)
     155 . W ?61,"Sex: ",$S(DGSEX="M":"MALE",DGSEX="F":"FEMALE",1:"UNANSWERED")
     156 ;
     157 ;
     158 ; field groups 1 & 2 part 5: show remaining name components and aliases
     159 ;
     160 ;
     161 N DGCOUNT F DGCOUNT=2:1:6 D
     162 . W !?5,$P(DGLABEL,U,DGCOUNT),": "
     163 . N DGNAME S DGNAME=$G(DGCOMP(20,DGCOMP,DGCOUNT)) ; next name component
     164 . W $E(DGNAME,1,$S(DGCOUNT=2:23,1:27)) ; 1st line leaves room for "[2]"
     165 . I DGCOUNT=2 D  ; header for aliases
     166 . . W ?37 N DGRPW,Z S DGRPW=0,Z=2 D WW^DGRPV ; write [2], suppress LF
     167 . . W " Alias: "
     168 . W ?47,$G(DGALIAS(DGCOUNT-1)) ; show next alias
     169 ;
     170 ;
     171 ; show field group 3: remarks
     172 ;
     173 ;
     174 ; ** end of VOE change 2 **
     175 ;
    20176 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
    21177 S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
    … …  
    29185 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)
    30186 W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
     187 ;
     188 ; ** VOE change 3 of 3 **
     189 ;
     190 ; if EHR agency code, display Alternate Phone Number (.134)
     191 ;
     192 ; new lines:
     193 I $G(DUZ("AG"))="E" D
     194 . W !?1,"Alt Ph: ",$P($G(^DPT(DFN,.13)),U,4)
     195 ;
     196 ; ** end of VOE change 3 **
     197 ;
    31198 W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
    32199 ;
    … …  
    50217 G ^DGRPP
    51218 ;
    52 GETNCAL ;Get name component values
    53  N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
    54  S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
    55  S DGCOMP=+$G(^DPT(DFN,"NAME"))_","
    56  I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
    57  ;Get alias values
    58  S DGA=0 F DGI=1:1:5 D  Q:'$D(DGALIAS(DGI))
    59 A2 .S DGA=$O(^DPT(DFN,.01,DGA))
    60  .I 'DGA D:DGI=1  Q
    61  ..S DGALIAS(DGI)="< No alias entries on file >" Q
    62  .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q
    63  .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2
    64  .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)
    65  .I $L(DGX) D
    66  ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)
    67  ..; BAJ DG*5.3*700 retrofit 06/22/06
    68  ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)
    69  ..S $E(DGALIAS(DGI),20)=DGX Q
    70  .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)
    71  .Q
    72  ;Display name component, sex, multiple birth indicator and alias data
    73  F DGI=1:1:6 D
    74  .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:23,1:27))
    75  .I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV
    76  .; BAJ DG*5.3*700 retrofit 06/2206
    77  .I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV
    78  .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "
    79  .I DGI>1 W ?47,$G(DGALIAS(DGI-1))
    80  .Q
    81  Q
    82219SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
    83220 S DGREAS=$P(DGRP("SSN"),U)

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

    r628 r636  
    11DGRP14 ;ALB/MRL/EG/GAH - REGISTRATION SCREEN 14/APPOINTMENT INFORMATION ; 10/18/06
    2  ;;5.3;Registration;**568,585,725,770**;Aug 13, 1993;Build 4
     2 ;;5.3;Registration;**568,585,725**;Aug 13, 1993;Build 12
    33 S DGRPS=14 D H^DGRPU S (Z,DGRPW)=1 D WW^DGRPV W " Enrollment Clinics: "
    44 S I1=""
    … …  
    1717 .;check to see if appointment is cancelled, if so
    1818 .;ignore this appointment eg 01/25/2005
    19  .;I $$CANCEL(DFN,APTDT)="Y" Q TAKEN OUT IN PATCH 770.
     19 .I $$CANCEL(DFN,APTDT)="Y" Q
    2020 .S CLNAM=$P($P(^TMP($J,"SDAMA301",DFN,APTDT),U,2),";",2)
    2121 .S X=$S(CLNAM]"":CLNAM,1:"UNKNOWN CLINIC")_" ("_$$FMTE^DILIBF(APTDT,"5U")_"), " W:(79-$X)<$L(X) !?24 W X

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

    r628 r636  
    1 DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300
    2  ;;5.3;Registration;**415,545,638,677,760**;Aug 13, 1993;Build 11
     1DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ; 1/5/2006  23:54
     2 ;;5.3;Registration;**415,545,638,677,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319 S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
    420 S DGRPX=DGRP(0)
    … …  
    925 ;S DGRPX=DGRP(0)
    1026 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)
    11  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
     27 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
    1228 W ?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU)
    1329 W !,?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU)
    14  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
    15  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)
     30 ;
     31 ; ** start of VOE change: DAOU,VA/CJS,WV/TOAD 1/5/2006 **
     32 ;
     33 ; New VOE Patient fields
     34 ;
     35 ; insert 7 lines:
     36 ;
     37 I $G(DUZ("AG"))="E" D
     38 . W !?4,"Veteran: ",$$GET1^DIQ(2,DFN,19902)
     39 . W !,"Interpreter Language: "
     40 . N IL S IL=""
     41 . N I F I=1:1 S IL=$O(^DPT(DFN,19901,"B",IL)) Q:IL=""  D
     42 . . I I'=1 W ","
     43 . . W $$GET1^DIQ(.85,IL,1)
     44 ;
     45 ; next three groups of lines have been conditionalized to only display
     46 ; for VA agency code; also, refactored for clarity
     47 ;
     48 I $G(DUZ("AG"))="V" D
     49 . W ! S Z=2 D WW^DGRPV
     50 . W " Previous Care Date      Location of Previous Care"
     51 . W !?4,"------------------      -------------------------"
     52 . S DGRPX=DGRP(1010.15)
     53 . ;
     54 . I $P(DGRPX,"^",5)'="Y" D
     55 . . S X="NONE INDICATED"
     56 . . W !?4,X,?28,X
     57 . ;
     58 . E  F I=1:1:4 D
     59 . . S I1=$P(DGRPX,"^",I)
     60 . . X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)"
     61 . . I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
     62 ;
     63 ; ** end of VOE change **
     64 ;
    1665 W ! S Z=3 D WW^DGRPV W " Ethnicity: " D
    1766 .I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q

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

    r628 r636  
    1 DGRP3 ;ALB/MRL - REGISTRATION SCREEN 3/CONTACT INFORMATION ;06 JUN 88@2300
    2  ;;5.3;Registration;;Aug 13, 1993
     1DGRP3 ;ALB/MRL - REGISTRATION SCREEN 3/CONTACT INFORMATION ;11/5/06  20:31
     2 ;;5.3;Registration;**634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319 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:"")
    420 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)
    … …  
    1127 F I=0:0 S I=$O(DGA(I)) Q:'I  S Z="              "_$E(DGA(I),1,27) W !,Z
    1228 W !?7,"Phone: ",$P(X,"^",3),?41,"Work Phone: ",$P(X,"^",4)
     29 ;New EHR code    ;DAOU/WCJ  2/7/05
     30 ;New fields for agency EHR
     31 I $G(DUZ("AG"))="E" S DGRPW=0,Z=6 W ! D WW^DGRPV S DGRPI=$G(^DPT(DFN,19900)) D
     32 .W "Year arrived in U.S.: ",$P(DGRPI,"^",6),!
     33 .W "Mother's Country of Birth: ",$P(DGRPI,"^",4),!
     34 .W "Father's Country of Birth: ",$P(DGRPI,"^",5),!
     35 ;End EHR modifications
    1336Q K DGRPI,DGRPI1
    1437 G ^DGRPP

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

    r628 r636  
    1 DGRPCE ;ALB/MRL,KV,PJR,BRM,ERC - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am
    2  ;;5.3;Registration;**121,122,175,297,342,451,626,689,653**;Aug 13, 1993;Build 2
     1DGRPCE ;ALB/MRL,KV,PJR,BRM - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am
     2 ;;5.3;Registration;**121,122,175,297,342,451,626,689,653,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319 ;
    420 ;KV;11/15/00;DG*5.3*297;Disable addition of CD Elig Code in Reg. Screens
    … …  
    925 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
    1026 I 'DGKEY(1) D:DGEK ELDR S I=15 D SASK S I=23 D SASK
     27 ;New EHR code  DAOU/WCJ  2/5/05
     28 ;skip veteran related fields for agency EHR
     29 G NKEY:$G(DUZ("AG"))="E"
     30 ;End EHR new code
    1131 F I=29,30,31,32,33,43,44,45,48,56 D SASK,MON:DGCCF S DGCCF=0
    1232 G NKEY:DGKEY(3) F I=25,26,27,28,34,35 D SASK
    … …  
    3959 S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
    4060ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38,"
    41  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
    42  I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
    43  D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
     61 ;Previous VA code prior to EHR changes
     62 ;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
     63 ;I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
     64 ;D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
     65 ;New code  DAOU/WCJ 2/5/05  Skip veteran specific fields
     66 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
     67 I 'DGKEY(2),$G(DUZ("AG"))'="E"  F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
     68 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
     69 ;End new code  DAOU/WCJ  2/5/05
    4470 I 'DGKEY(1) D ELIG^DGRPCE1
    4571 Q

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

    r628 r636  
    1 DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC-PATIENT INQUIRY (NEW) ; 3/9/06 11:17am
    2  ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703**;Aug 13, 1993
     1DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC-PATIENT INQUIRY (NEW) ;1/27/07  13:14
     2 ;;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
     3 ; Modified from FOIA VISTA
     4 ; GPL Copyright (C) 2007 WorldVistA
    35 ;  *286*  Newing variables X,Y in OKLINE subroutine
    4  ;  *358*  If a patient is on a domiciliary ward, don't display MEANS
    5  ;         TEST required/Medication Copayment Exemption messages
    6  ;  *436*  If an inpatient is not on a domiciliary ward, don't display
    7  ;         Medication Copayment Exemption message
    8  ;  *545*  Add death information near the remarks field
    9  ;  *677*  Added Emergency Response
     6 ; 
    107SEL 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
     8 ;
    119EN ;call to display patient inquiry - input DFN
    1210 ;MPI/PD CHANGE
    … …  
    5149 .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0))  W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
    5250 I '$$OKLINE(16) G Q
    53  ;display cv status #4156
    54  N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
    55  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")
     51 ;
     52 ; VOE change
     53 ;
     54 I DUZ("AG")="V" D
     55 . ;display cv status #4156
     56 . N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
     57 . 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")
     58 ;
     59 ; end VOE change
     60 ;
    5661 ;display primary eligibility
    5762 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)
    … …  
    111116HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
    112117 ;MPI/PD CHANGE
    113  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
     118 ; VOE CHANGE
     119 ; 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
     120 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
    114121 ;END MPI/PD CHANGE
     122HRNV(DFN) ;
     123 N IRET
     124 S IRET=$$HRN^DGLBPID(DFN)
     125 I IRET="#" Q ""
     126 S IRET="HRN "_IRET
     127 Q IRET
     128 ; END VOE CHANGE
     129 ;
    115130INP S VAIP("D")="L" D INP^DGPMV10
    116131 S DGPMT=0

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

    r628 r636  
    11DGRPDB ;ALB/AAS,JAN,ERC,PHH - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ; 3/23/06 8:16am
    2  ;;5.3;Registration;**26,50,358,570,631,709,713,749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;**26,50,358,570,631,709,713**;Aug 13, 1993
    33 ;
    44% S:'$D(DGQUIT) DGQUIT=0
    … …  
    6262 ;
    6363AOIR ;Agent Orange/ionizing radiation
    64  N DGEC,NTA
    6564 S DGX=$S($D(^DPT(DFN,.321)):^(.321),1:"")
    6665 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"),"   "
    6766 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,"@")
    68  S DGEC=$S($D(^DPT(DFN,.322)):^DPT(DFN,.322),1:"")
    69  S X=$P(DGEC,U,13) W !,"        Env Contam.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED"),"   "
    70  S NTA=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
    71  K DGNTARR
    72  W "N/T Radium: " W $S(NTA'="":NTA,1:"NOT ANSWERED")
    7367 Q
    7468 ;

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

    r628 r636  
    1 DGRPE ;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ; 09/12/05 1:27pm
    2  ;;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**;Aug 13, 1993;Build 11
     1DGRPE ;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ;1/27/07  13:11
     2 ;;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
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ;
     12 ; VOE changes: DAOU,VA/CJS,WV/TOAD 5/9/2006
     13 ; conditionally add edit fields to the following lines:
     14 ;    201: Is Patient a Veteran (19902), Interpreter Language (19906)
     15 ;    202: skip line if agency code for IHS or VOE
     16 ; 305002+1: for VOE, Mother's Country of Birth (19903), Father's Country
     17 ;         of Birth (19904), Year Arrived in U.S. (19905)
    318 ;
    419 ;DGDR contains a string of edits; edit=screen*10+item #
    … …  
    5368 Q
    5469 ;
     70 ; VOE changes at lines 201, 202, 304 & after 305002
     71 ;
    5572SETFLDS(DGDR) ; Set up fields to edit
    5673 Q
    … …  
    6683111000 ;;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^");
    6784112 ;;.134;.135;.133
    68 201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;
    69 202 ;;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^");
     85201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
     86202 ;;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^");
    7087203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
    7188205 ;;.181;
    … …  
    8299305001 ;;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
    83100305002 ;;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;
     101 ;;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;
    84102401 ;;.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;
    85103402 ;;.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;

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

    r628 r636  
    1 DGRPECE ;ALB/MRY,ERC - REGISTRATION CATASTROPHIC EDITS ; 10/4/06 2:35pm
    2  ;;5.3;Registration;**638,682,700,720,653**;Aug 13, 1993;Build 2
     1DGRPECE ;ALB/MRY - REGISTRATION CATASTROPHIC EDITS ;1/6/07  13:28
     2 ;;5.3;Registration;**638,682,700,720,653,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319 ;
    420CEDITS(DFN) ;catastrophic edits  - buffer values, save after check
    … …  
    3753 S DIR(0)="2,.09^^"
    3854 S DA=DFN D ^DIR
    39  I $D(DIRUT) D CECHECK Q
     55 I $D(DIRUT),DUZ("AG")="V" D CECHECK Q  ; VOE modification, SSN may be null
     56 I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
    4057 S BUFFER("SSN")=Y
    4158 ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC
    … …  
    6279 S DIR(0)="2,.03^^"
    6380 S DA=DFN D ^DIR
    64  I $D(DIRUT) D CECHECK Q
     81 I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
     82 I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
    6583 S BUFFER("DOB")=Y
    6684SEX ;buffer - get sex
    6785 S DIR(0)="2,.02^^"
    6886 S DA=DFN D ^DIR
    69  I $D(DIRUT) D CECHECK Q
     87 I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
     88 I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
    7089 S BUFFER("SEX")=Y
    7190MBI ; buffer - get MBI (multiple birth indicator)

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

    r628 r636  
    1 DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TEMPLATE(#1476), FILE 2;04/10/06
     1DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TEMPLATE(#1476), FILE 2;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    … …  
    106106 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
    107107 I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
    108 C4F1 N X,X1,X2 S DIXR=643 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
     108C4F1 N X,X1,X2 S DIXR=664 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
    109109 I $G(X(1))]"" D
    110110 . K ^DPT("APTYPE",X,DA)

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

    r628 r636  
    1 DGRPTX1 ; ;04/10/06
     1DGRPTX1 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 ;

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

    r628 r636  
    1 DGRPTX10 ; ;04/10/06
     1DGRPTX10 ; ;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    … …  
    6262 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    6363C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    64  F DIXR=605 S DIEZRXR(2,DIXR)=""
     64 F DIXR=602 S DIEZRXR(2,DIXR)=""
    6565 Q
    6666X1 K:$L(X)>30!($L(X)<1) X I $D(X) S DFN=DA D K1^DGLOCK2
    … …  
    7777C3S S X="" G:DG(DQ)=X C3F1 K DB
    7878C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    79  F DIXR=605 S DIEZRXR(2,DIXR)=""
     79 F DIXR=602 S DIEZRXR(2,DIXR)=""
    8080 Q
    8181X3 I $D(X),X="Y" S DFN=DA D K1^DGLOCK2
    … …  
    9999 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    100100C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    101  F DIXR=605 S DIEZRXR(2,DIXR)=""
     101 F DIXR=602 S DIEZRXR(2,DIXR)=""
    102102 Q
    103103X5 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
    … …  
    122122 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    123123C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    124  F DIXR=605 S DIEZRXR(2,DIXR)=""
     124 F DIXR=602 S DIEZRXR(2,DIXR)=""
    125125 Q
    126126X7 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
    … …  
    137137C9S S X="" G:DG(DQ)=X C9F1 K DB
    138138C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    139  F DIXR=605 S DIEZRXR(2,DIXR)=""
     139 F DIXR=602 S DIEZRXR(2,DIXR)=""
    140140 Q
    141141X9 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
    … …  
    153153 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    154154C10F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    155  F DIXR=605 S DIEZRXR(2,DIXR)=""
     155 F DIXR=602 S DIEZRXR(2,DIXR)=""
    156156 Q
    157157X10 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
    … …  
    170170 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    171171C11F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    172  F DIXR=605 S DIEZRXR(2,DIXR)=""
     172 F DIXR=602 S DIEZRXR(2,DIXR)=""
    173173 Q
    174174X11 I $D(X) S DFN=DA D K1^DGLOCK2
    … …  
    186186 D SET^DGREGDD1(DA,.218,.21,8,$E(X,1,5))
    187187C12F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    188  F DIXR=605 S DIEZRXR(2,DIXR)=""
     188 F DIXR=602 S DIEZRXR(2,DIXR)=""
    189189 Q
    190190X12 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

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

    r628 r636  
    1 DGRPTX11 ; ;04/10/06
     1DGRPTX11 ; ;04/21/06
    22 S X=DE(13),DIC=DIE
    33 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)

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

    r628 r636  
    1 DGRPTX12 ; ;04/10/06
     1DGRPTX12 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)

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

    r628 r636  
    1 DGRPTX13 ; ;04/10/06
     1DGRPTX13 ; ;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    … …  
    6060C1S S X="" G:DG(DQ)=X C1F1 K DB
    6161C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    62  F DIXR=607 S DIEZRXR(2,DIXR)=""
     62 F DIXR=604 S DIEZRXR(2,DIXR)=""
    6363 Q
    6464X1 I $D(X),X="Y" D K1^DGLOCK2
    … …  
    9797 Q
    9898C6F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    99  F DIXR=607 S DIEZRXR(2,DIXR)=""
     99 F DIXR=604 S DIEZRXR(2,DIXR)=""
    100100 Q
    101101X6 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
    … …  
    112112C8S S X="" G:DG(DQ)=X C8F1 K DB
    113113C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    114  F DIXR=607 S DIEZRXR(2,DIXR)=""
     114 F DIXR=604 S DIEZRXR(2,DIXR)=""
    115115 Q
    116116X8 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D E1^DGLOCK2
    … …  
    128128 ;
    129129C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    130  F DIXR=607 S DIEZRXR(2,DIXR)=""
     130 F DIXR=604 S DIEZRXR(2,DIXR)=""
    131131 Q
    132132X9 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
    … …  
    147147 ;
    148148C11F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    149  F DIXR=607 S DIEZRXR(2,DIXR)=""
     149 F DIXR=604 S DIEZRXR(2,DIXR)=""
    150150 Q
    151151X11 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
    … …  
    162162C13S S X="" G:DG(DQ)=X C13F1 K DB
    163163C13F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    164  F DIXR=607 S DIEZRXR(2,DIXR)=""
     164 F DIXR=604 S DIEZRXR(2,DIXR)=""
    165165 Q
    166166X13 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
    … …  
    174174C14S S X="" G:DG(DQ)=X C14F1 K DB
    175175C14F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    176  F DIXR=607 S DIEZRXR(2,DIXR)=""
     176 F DIXR=604 S DIEZRXR(2,DIXR)=""
    177177 Q
    178178X14 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
    … …  
    187187C15S S X="" G:DG(DQ)=X C15F1 K DB
    188188C15F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    189  F DIXR=607 S DIEZRXR(2,DIXR)=""
     189 F DIXR=604 S DIEZRXR(2,DIXR)=""
    190190 Q
    191191X15 I $D(X) S DFN=DA D E1^DGLOCK2
    … …  
    201201 D ^DGRPTX15
    202202C16F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    203  F DIXR=607 S DIEZRXR(2,DIXR)=""
     203 F DIXR=604 S DIEZRXR(2,DIXR)=""
    204204 Q
    205205X16 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

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

    r628 r636  
    1 DGRPTX14 ; ;04/10/06
     1DGRPTX14 ; ;04/21/06
    22 S X=DE(16),DIC=DIE
    33 D KILL^DGREGDD1(DA,.338,.33,8,$E(X,1,5))

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

    r628 r636  
    1 DGRPTX15 ; ;04/10/06
     1DGRPTX15 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 D SET^DGREGDD1(DA,.338,.33,8,$E(X,1,5))

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

    r628 r636  
    1 DGRPTX16 ; ;04/10/06
     1DGRPTX16 ; ;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    … …  
    143143 S X=DG(DQ),DIC=DIE
    144144 D EVENT^IVMPLOG(DA)
    145 C6F1 N X,X1,X2 S DIXR=627 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
     145C6F1 N X,X1,X2 S DIXR=646 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
    146146 D
    147147 . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q

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

    r628 r636  
    1 DGRPTX17 ; ;04/10/06
     1DGRPTX17 ; ;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

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

    r628 r636  
    1 DGRPTX18 ; ;04/10/06
     1DGRPTX18 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPTX19 ; ;04/10/06
     1DGRPTX19 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 ;

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

    r628 r636  
    1 DGRPTX2 ; ;04/10/06
     1DGRPTX2 ; ;04/21/06
    22 S X=DE(9),DIC=DIE
    33 X "S DGXRF=.112 D ^DGDDC Q"

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

    r628 r636  
    1 DGRPTX20 ; ;04/10/06
     1DGRPTX20 ; ;04/21/06
    22 S X=DE(11),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPTX21 ; ;04/10/06
     1DGRPTX21 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPTX22 ; ;04/10/06
     1DGRPTX22 ; ;04/21/06
    22 S X=DE(12),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPTX23 ; ;04/10/06
     1DGRPTX23 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPTX24 ; ;04/10/06
     1DGRPTX24 ; ;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

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

    r628 r636  
    1 DGRPTX25 ; ;04/10/06
     1DGRPTX25 ; ;04/21/06
    22 D DE G BEGIN
    33DE 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,""))=""

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

    r628 r636  
    1 DGRPTX26 ; ;04/10/06
     1DGRPTX26 ; ;04/21/06
    22 ;;
    3 1 N X,X1,X2 S DIXR=605 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=602 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 D
    55 . D PNOK^DGDDDTTM
    … …  
    2020 S X=$G(X(1))
    2121 Q
    22 2 N X,X1,X2 S DIXR=607 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     222 N X,X1,X2 S DIXR=604 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    2323 D
    2424 . D ECON^DGDDDTTM

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

    r628 r636  
    1 DGRPTX27 ; ;08/13/05
     1DGRPTX27 ; ;12/08/05
    22 D DE G BEGIN
    33DE 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,""))=""

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

    r628 r636  
    1 DGRPTX28 ; ;08/13/05
     1DGRPTX28 ; ;12/08/05
    22 S X=DE(8),DIC=DIE
    33 K ^DPT("APOS",$E(X,1,30),DA)

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

    r628 r636  
    1 DGRPTX29 ; ;08/13/05
     1DGRPTX29 ; ;12/08/05
    22 S X=DG(DQ),DIC=DIE
    33 S ^DPT("APOS",$E(X,1,30),DA)=""

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

    r628 r636  
    1 DGRPTX3 ; ;04/10/06
     1DGRPTX3 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 ;

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

    r628 r636  
    1 DGRPTX30 ; ;08/13/05
     1DGRPTX30 ; ;12/08/05
    22 ;;
    3 1 N X,X1,X2 S DIXR=605 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=602 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 D
    55 . D PNOK^DGDDDTTM

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

    r628 r636  
    1 DGRPTX4 ; ;04/10/06
     1DGRPTX4 ; ;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

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

    r628 r636  
    1 DGRPTX5 ; ;04/10/06
     1DGRPTX5 ; ;04/21/06
    22 S X=DE(5),DIC=DIE
    33 S A1B2TAG="PAT" D ^A1B2XFR

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

    r628 r636  
    1 DGRPTX6 ; ;04/10/06
     1DGRPTX6 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 S A1B2TAG="PAT" D ^A1B2XFR

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

    r628 r636  
    1 DGRPTX7 ; ;04/10/06
     1DGRPTX7 ; ;04/21/06
    22 S X=DE(7),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPTX8 ; ;04/10/06
     1DGRPTX8 ; ;04/21/06
    22 S X=DG(DQ),DIC=DIE
    33 ;

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

    r628 r636  
    1 DGRPTX9 ; ;04/10/06
     1DGRPTX9 ; ;04/21/06
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    … …  
    189189 Q
    190190C6F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    191  F DIXR=605 S DIEZRXR(2,DIXR)=""
     191 F DIXR=602 S DIEZRXR(2,DIXR)=""
    192192 Q
    193193X6 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

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

    r628 r636  
    1 DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;19 OCT 2005
    2  ;;5.3;Registration;**33,114,489,624,672,689**;Aug 13, 1993;Build 1
     1DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;12/25/06  18:28
     2 ;;5.3;Registration;**33,114,489,624,672,689,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319H ;Screen Header
    420 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
    … …  
    165181 Q
    166182SSNNM(DFN) ; SSN and name on first line of screen
    167  N X,SSN
    168  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)
     183 ;
     184 ; ** start of VOE change: DAOU/JLG 2/1/2005,VA/CJS,WV/TOAD 5/9/2006 **
     185 ;
     186 ; Change code so it will display HRN if SSN is null
     187 ;
     188 ; before:
     189 ;
     190 ; N X,SSN
     191 ; 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)
     192 ;
     193 ; after:
     194 ;
     195 ; Social Security Number field (.09) in Patient file (2)
     196 N X,SSN,HRN
     197 S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9)
     198 I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
     199 ;
     200ID S SSN=$$ID^DGLBPID(DFN) ;**GFT/VW
     201 ; for IHS or EHR, replace SSN with HRN
     202 I $G(DUZ("AG"))'="V" D
     203 . Q:SSN]""
     204 . S HRN=$$HRN^AUPNPAT3(+DFN,DUZ(2))
     205 . I HRN S SSN="HRN-"_HRN
     206 ;
     207 ; ** end of VOE change **
     208 ;
    169209 S X=$P(X,U)_"; "_SSN
    170210 Q X

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

    r628 r636  
    11DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA - REGISTRATION DEFINE VARIABLES ON ENTRY ; 8/11/05 12:56pm
    2  ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716**;Aug 13, 1993
     2 ;;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
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    319 ;
    420 ;
    … …  
    2945 . S DGRPVV="000000000000000"
    3046 S X="5^3^5^2^3^8^4^2^10^2^4^5^5^2^1"
     47 ;
     48 ; ** VOE change 1 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
     49 ;
     50 ; new line: if agency code is not VA, new section added to screen 3
     51 I $G(DUZ("AG"))'="V" S $P(X,"^",3)="6"
     52 ;
     53 ; ** end of VOE change 1 **
     54 ;
    3155 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))
    3256 S DGRPVV(1.1)="00"
    … …  
    4165 ;-- commented the line to allow screens 2 & 4 to display for Tricare
    4266 ;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)
     67 ;
     68 ; ** VOE change 2 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
     69 ;
     70 ; add lines: if agency code is not VA, change last screen to 14,
     71 ; and clear flag for screen 15 (it is VA-specific)
     72 I $G(DUZ("AG"))'="V" D
     73 . S DGRPLAST=14
     74 . F I=15 S DGRPVV=$E(DGRPVV,0,I-1)_$S(I=15:"",1:1)_$E(DGRPVV,I+1,99)
     75 ;
     76 ; ** end of VOE change 2 **
    4377 ;
    4478 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)
    … …  
    5892 F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
    5993 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
     94 ;
     95 ; ** VOE change 3 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
     96 ;
     97 ; add line: if agency code is not VA, only edit one section of screen 7
     98 ; The rest is veteran specific.
     99 I $G(DUZ("AG"))'="V" S DGRPVV(7)="1101"
     100 ;
     101 ; ** end of VOE change 3 **
     102 ;
    60103 I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
    61104 I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
    … …  
    69112 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
    70113 S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
     114 ;
     115 ; ** VOE change 4 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
     116 ;
     117 ; add line: if agency code is not VA, and last screen is set to 15, set
     118 ; it to 14 (it is VA-specific)
     119 I $G(DUZ("AG"))'="V",DGRPLAST=15 S DGRPLAST=14
     120 ;
     121 ; ** end of VOE change 4 **
     122 ;
    71123 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
    72124Q K DGRPSC,DGRPSCE

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

    r628 r636  
    1 DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLATE(#420), FILE 2;06/27/07
     1DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLATE(#420), FILE 2;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    … …  
    7070 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
    7171 I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
    72 C2F1 N X,X1,X2 S DIXR=643 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X
     72C2F1 N X,X1,X2 S DIXR=664 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X
    7373 I $G(X(1))]"" D
    7474 . K ^DPT("APTYPE",X,DA)

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

    r628 r636  
    1 DGRPX71 ; ;06/27/07
     1DGRPX71 ; ;12/27/07
    22 S X=DE(9),DIC=DIE
    33 D AUTOUPD^DGENA2(DA)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX710.m

    r628 r636  
    1 DGRPX710 ; ;06/27/07
     1DGRPX710 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX711.m

    r628 r636  
    1 DGRPX711 ; ;06/27/07
     1DGRPX711 ; ;12/27/07
    22 D DE G BEGIN
    33DE 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,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX712.m

    r628 r636  
    1 DGRPX712 ; ;06/27/07
     1DGRPX712 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 S A1B2TAG="PAT" D ^A1B2XFR

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX713.m

    r628 r636  
    1 DGRPX713 ; ;06/27/07
     1DGRPX713 ; ;12/27/07
    22 D DE G BEGIN
    33DE 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,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX714.m

    r628 r636  
    1 DGRPX714 ; ;12/28/06
     1DGRPX714 ; ;01/18/07
    22 D DE G BEGIN
    33DE 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,""))=""

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

    r628 r636  
    1 DGRPX72 ; ;06/27/07
     1DGRPX72 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 D AUTOUPD^DGENA2(DA)

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

    r628 r636  
    1 DGRPX73 ; ;06/27/07
     1DGRPX73 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""

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

    r628 r636  
    1 DGRPX74 ; ;06/27/07
     1DGRPX74 ; ;12/27/07
    22 S X=DE(11),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPX75 ; ;06/27/07
     1DGRPX75 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPX76 ; ;06/27/07
     1DGRPX76 ; ;12/27/07
    22 S X=DE(12),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPX77 ; ;06/27/07
     1DGRPX77 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 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)

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

    r628 r636  
    1 DGRPX78 ; ;06/27/07
     1DGRPX78 ; ;12/27/07
    22 S X=DE(14),DIC=DIE
    33 X "S DFN=DA D EN^DGMTR K DGREQF"

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

    r628 r636  
    1 DGRPX79 ; ;06/27/07
     1DGRPX79 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 X "S DFN=DA D EN^DGMTR K DGREQF"

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

    r628 r636  
    1 DGRUGA01 ;ALB/GRR - HL7 ADT A01 MESSAGE BUILDER ; 11/27/07 1:43pm
    2  ;;5.3;Registration;**190,303,762**;Aug 13, 1993;Build 3
     1DGRUGA01 ;ALB/GRR - HL7 ADT A01 MESSAGE BUILDER ;06/08/99
     2 ;;5.3;Registration;**190,303**;Aug 13, 1993
    33 ;
    44 ;This routine will build a ADT A01 (Admit) HL7 message for an inpatient.
    … …  
    3636 .S:DGPCPNM="" DGPCPNM=HL("Q")
    3737 .S $P(DGPV1,HL("FS"),8)=DGPCPPTR_$E(HL("ECH"))_DGPCPNM
    38  .K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
    3938 .;Get current ward & room/bed
    4039 .S DGW=$$GET1^DIQ(2,DFN,.1,"I")
    … …  
    5049 I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT) S $P(@DGARRAY@(1),HL("FS"),7)=$$HLDATE^HLFNC(DGOADT)
    5150 S DGPV1=$$DOCID^DGRUUTL(DGPV1)
    52  K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
    5351 ;TRANSLATE WARD AND ROOM-BED NAMES IF NEEDED (ALREADY DONE IF SEEDING)
    5452 S:'$G(DGSEED) DGPV1=$$LOCTRAN^DGRUUTL1(DGPV1)

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

    r628 r636  
    1 DGRUGA08 ;ALB/GRR - HL7 ADT A08 MESSAGE BUILDER ; 10/11/07 9:24am
    2  ;;5.3;Registration;**190,312,328,721,762**;Aug 13, 1993;Build 3
     1DGRUGA08 ;ALB/GRR - HL7 ADT A08 MESSAGE BUILDER ; 21 Sep 2006  8:24 AM
     2 ;;5.3;Registration;**190,312,328,721**;Aug 13, 1993;Build 3
    33 ;
    44 ;This routine will build a ADT A08 (Patient Update) HL7 message for an inpatient.
    … …  
    1616 N DGPV1,DGHOLD,DGCNT,DGMDT,DGCDT,DGOADT,DGIN1,DGLMT,DGZEL,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
    1717 Q:DGARRAY=""  ;Required output variable name was not passed
    18  K @DGARRAY ;Kill output array to insure erroneous data does not exist
     18 K @DGARRAY ;Kill output array to insure erronuous data does not exist
    1919 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
    2020 D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
    … …  
    3333 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
    3434 N VAIP D IN5^VADPT S $P(DGPV1,HL("FS"),11)=$$GET1^DIQ(45.7,+VAIP(8),1,"I") K VAIP ; p-721
    35  K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
    3635 S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1)
    3736 S DGCNT=DGCNT+1 ;Increment node counter to store next segment

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

    r628 r636  
    1 DGRUGA22 ;ALB/GRR - HL7 ADT A22 MESSAGE BUILDER ; 11/7/07 3:45pm
    2  ;;5.3;Registration;**190,762**;Aug 13, 1993;Build 3
     1DGRUGA22 ;ALB/GRR - HL7 ADT A22 MESSAGE BUILDER ;8/5/99  15:36
     2 ;;5.3;Registration;**190**;Aug 13, 1993
    33 ;
    44 ;This routine will build a ADT A22 (From Leave of Absence) HL7 message for an inpatient.
    … …  
    1414 N DGPV1,DGCNT,DGMDT,DGCDT,DGOADT,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
    1515 Q:DGARRAY=""  ;Required output variable name was not passed
    16  K @DGARRAY ;Kill output array to insure erroneous data does not exist
     16 K @DGARRAY ;Kill output array to insure erronuous data does not exist
    1717 Q:DGMIEN=""
    1818 S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
    … …  
    2828 I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT)
    2929 S DGPV1=$$DOCID^DGRUUTL(DGPV1)
    30  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
    3130 S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1) ;Translate Ward and Room-Bed name, store into array
    3231 S DGMTYP=$$GET1^DIQ(405,DGMIEN,.18,"I") ;Get Movement Type

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

    r628 r636  
    1 DGRUGBJ ; ALB/SCK - RAI/MDS COTS ADT Background job ; 11/7/07 3:49pm
    2  ;;5.3;Registration;**190,312,357,762**;Aug 13, 1993;Build 3
     1DGRUGBJ ; ALB/SCK - RAI/MDS COTS ADT Background job ; 8-10-99
     2 ;;5.3;Registration;**190,312,357**;Aug 13, 1993
    33 ;
    44EN ; Main Entry point for patient demographic update to COTS system
    … …  
    2626 . ; Check for patient, if not valid, then mark as transmitted and quit
    2727 . I ('$D(^DPT(DFN,0))) D XMITFLAG^VAFCDD01(PVTPTR,"",1) Q
    28  . N VAIN D INP^VADPT ; p-762
    29  . I '$$CHKWARD^DGRUUTL(+VAIN(4)) D XMITFLAG^VAFCDD01(PVTPTR,"",1) K VAIN Q  ; P-762
     28 . ;
    3029 . K @DGARRAY
    3130 . S @DGARRAY@("PIVOT")=PVTPTR
    … …  
    9493 Q (HLRST)
    9594 ;
    96 ERRBUL(EVNTINFO,RESULT) ; Generate bulletin if an error occurred while building the HL7 message.
     95ERRBUL(EVNTINFO,RESULT) ; Generate bulliten if an error occurred while building the HL7 message.
    9796 ;
    9897 N XMY,XMDUZ,XMDT,XMZ,XMB,XMCHAN,XMSUB

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

    r628 r636  
    1 DGRUUTL ;ALB/GRR - RAI/MDS UTILITY ROUTINE ; 10/11/07 8:42am
    2  ;;5.3;Registration;**190,444,762**;Aug 13, 1993;Build 3
     1DGRUUTL ;ALB/GRR - RAI/MDS UTILITY ROUTINE
     2 ;;5.3;Registration;**190,444**;Aug 13, 1993
    33HLNAME(DGNAME) ;Piece apart name into LAST NAME_"^"_FIRST NAME_"^"_MIDDLE NAME_"^"_SUFFIX
    44 ;Input DGNAME - Either Last Name, First or First, Middle and Last Name (i.e. SMITH,JOHN R   or  JOHN R SMITH)
    … …  
    3939 ;
    4040 ;  Returns the medicaid information from the patient file
    41  ; P-762 return Medicaid number or 'N'
    42  N A S A=$$GET1^DIQ(2,DFN,.383)
    43  S:A="" A="N"
    44  Q A
     41 Q $$GET1^DIQ(2,DFN,.383)
    4542 ;
    4643GETAMOV(DFN) ;GET LAST ADMISSION MOVEMENT FOR A PATIENT
    … …  
    8885EXITDOC Q X
    8986 ;
    90 ATTDOC(X) ;get attending physician - p-762
    91  N ATTPTR,ATTNAME,VAIP D IN5^VADPT S ATTPTR=$P(VAIP(18),"^",1),ATTNAME=$P(VAIP(18),"^",2) K VAIP
    92  I $L(ATTPTR)>6 S ATTPTR=$E(ATTPTR,$L(ATTPTR)-5,$L(ATTPTR))
    93  I $G(ATTNAME) S ATTNAME=$$HLNAME(ATTNAME)
    94  Q ATTPTR_$E(HL("ECH"))_ATTNAME

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F.m

    r628 r636  
    1 DGX5F ; GENERATED FROM 'DG501F' INPUT TEMPLATE(#429), FILE 45;09/05/07
     1DGX5F ; GENERATED FROM 'DG501F' INPUT TEMPLATE(#429), FILE 45;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F1.m

    r628 r636  
    1 DGX5F1 ; ;09/05/07
     1DGX5F1 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
    … …  
    6363 S ^DGPT(DA(1),"M","AM",$E(X,1,30),DA)=""
    6464C2F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    65  F DIXR=447,448,449,450,451,452,453,454,455,456 S DIEZRXR(45.02,DIXR)=""
     65 F DIXR=462,463,464,465,466,467,468,469,470,471 S DIEZRXR(45.02,DIXR)=""
    6666 Q
    6767X2 S %DT="ETX" D ^%DT S X=Y K:Y<1 X I $D(X) X $S(X<$P(^DGPT(DA(1),0),U,2):"W !,""Not before admission"" K X",X>($S($D(^(70)):$S(+^(70):+^(70),1:9999999),1:9999999)):"W !,""Not after discharge"" K X",1:"")
    … …  
    154154 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    155155C25F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    156  F DIXR=447 S DIEZRXR(45.02,DIXR)=""
     156 F DIXR=462 S DIEZRXR(45.02,DIXR)=""
    157157 Q
    158158X25 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=5 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    175175 D ^DGX5F3
    176176C29F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    177  F DIXR=448 S DIEZRXR(45.02,DIXR)=""
     177 F DIXR=463 S DIEZRXR(45.02,DIXR)=""
    178178 Q
    179179X29 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=6 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F2.m

    r628 r636  
    1 DGX5F2 ; ;09/05/07
     1DGX5F2 ; ;12/27/07
    22 S X=DE(29),DIC=DIE
    33 K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F3.m

    r628 r636  
    1 DGX5F3 ; ;09/05/07
     1DGX5F3 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F4.m

    r628 r636  
    1 DGX5F4 ; ;09/05/07
     1DGX5F4 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
    … …  
    6666 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    6767C1F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    68  F DIXR=449 S DIEZRXR(45.02,DIXR)=""
     68 F DIXR=464 S DIEZRXR(45.02,DIXR)=""
    6969 Q
    7070X1 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    9393 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    9494C5F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    95  F DIXR=450 S DIEZRXR(45.02,DIXR)=""
     95 F DIXR=465 S DIEZRXR(45.02,DIXR)=""
    9696 Q
    9797X5 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    … …  
    120120 X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
    121121C9F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    122  F DIXR=451 S DIEZRXR(45.02,DIXR)=""
     122 F DIXR=466 S DIEZRXR(45.02,DIXR)=""
    123123 Q
    124124X9 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F5.m

    r628 r636  
    1 DGX5F5 ; ;09/05/07
     1DGX5F5 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F6.m

    r628 r636  
    1 DGX5F6 ; ;09/05/07
     1DGX5F6 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F7.m

    r628 r636  
    1 DGX5F7 ; ;09/05/07
     1DGX5F7 ; ;12/27/07
    22 ;;
    3 1 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     31 N X,X1,X2 S DIXR=462 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
    44 I $G(X(1))]"",$G(X(2))]"" D
    55 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
    … …  
    1212 S X=$G(X(1))
    1313 Q
    14 2 N X,X1,X2 S DIXR=448 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
     142 N X,X1,X2 S DIXR=463 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
    1515 I $G(X(1))]"",$G(X(2))]"" D
    1616 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
    … …  
    2323 S X=$G(X(1))
    2424 Q
    25 3 N X,X1,X2 S DIXR=449 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
     253 N X,X1,X2 S DIXR=464 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
    2626 I $G(X(1))]"",$G(X(2))]"" D
    2727 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
    … …  
    3434 S X=$G(X(1))
    3535 Q
    36 4 N X,X1,X2 S DIXR=450 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
     364 N X,X1,X2 S DIXR=465 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
    3737 I $G(X(1))]"",$G(X(2))]"" D
    3838 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
    … …  
    4545 S X=$G(X(1))
    4646 Q
    47 5 N X,X1,X2 S DIXR=451 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
     475 N X,X1,X2 S DIXR=466 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
    4848 I $G(X(1))]"",$G(X(2))]"" D
    4949 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")
    … …  
    5656 S X=$G(X(1))
    5757 Q
    58 6 N X,X1,X2 S DIXR=452 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
     586 N X,X1,X2 S DIXR=467 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
    5959 I $G(X(1))]"",$G(X(2))]"" D
    6060 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD6")
    … …  
    6767 S X=$G(X(1))
    6868 Q
    69 7 N X,X1,X2 S DIXR=453 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
     697 N X,X1,X2 S DIXR=468 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
    7070 I $G(X(1))]"",$G(X(2))]"" D
    7171 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD7")
    … …  
    7878 S X=$G(X(1))
    7979 Q
    80 8 N X,X1,X2 S DIXR=454 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
     808 N X,X1,X2 S DIXR=469 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
    8181 I $G(X(1))]"",$G(X(2))]"" D
    8282 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD8")
    … …  
    8989 S X=$G(X(1))
    9090 Q
    91 9 N X,X1,X2 S DIXR=455 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
     919 N X,X1,X2 S DIXR=470 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
    9292 I $G(X(1))]"",$G(X(2))]"" D
    9393 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD9")
    … …  
    100100 S X=$G(X(1))
    101101 Q
    102 10 N X,X1,X2 S DIXR=456 D X10(U) K X2 M X2=X D X10("F") K X1 M X1=X
     10210 N X,X1,X2 S DIXR=471 D X10(U) K X2 M X2=X D X10("F") K X1 M X1=X
    103103 I $G(X(1))]"",$G(X(2))]"" D
    104104 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD10")

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

    r628 r636  
    1 DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 3/22/05 4:19pm
    2  ;;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**;Aug 13, 1993
     1DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ;1/27/07  13:12
     2 ;;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
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
    311 ;
    412 ; mods made for magstripe read 12/96 - JFP
    … …  
    816 ;
    917EN ; -- Entry point
     18 ;Following line so VOE will use alternate lookup routine, DAOU,VA/CJS,WV/TOAD
     19 I $G(DUZ("AG"))'="V" D ^AUPNLK Q
    1020 N DIE,DR
    1121 K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X)))

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

    r628 r636  
    11VADATE ;ALB/MLI - GENERIC DATE ROUTINE ; 1 DEC 88 @1000
    2  ;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;;Aug 13, 1993
    33 ;
    44 I $D(VADAT("F")),$S(VADAT("F")<1:1,VADAT("F")>2:1,1:0) K VADAT("F")
    5  I '$D(VADAT("W")) S VANOW=$$NOW^XLFDT
    6  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))
     5 I '$D(VADAT("W")) D NOW^%DTC
     6 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))
    77 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)
    88 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:"")
    … …  
    1313 S VADATE("E")=VADATE("E")_$S(VA(3):$E(VAY,3,4),1:"")_$S($D(VAT):"@"_VAT,1:"")
    1414QUIT I $D(VADAT("J")),VADAT("J")?.N F I=$L(VADATE("E"))+1:1:VADAT("J") S VADATE("E")=" "_VADATE("E")
    15  K %DT,VA,VAD,VADEL,VAM,VAT,VAX,VAY,VANOW Q
     15 K %DT,VA,VAD,VADEL,VAM,VAT,VAX,VAY Q
    1616KVAR K VADAT,VADATE Q

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

    r628 r636  
    1 VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ; 08 DEC 1988 ; 11/9/04 6:17pm
    2  ;;5.3;Registration;**415,489,516,614**;Aug 13, 1993
     1VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ;1/27/07  15:00
     2 ;;5.3;Registration;**415,489,516,614,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    3191 ;Demographic [DEM]
    420 N W,Z,NODE
    … …  
    1531 ; -- age [4 - AG]
    1632 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))
     33 ;
     34 ; Added for VOE to support pediatrics
     35 ;
     36 I @VAV@($P(VAS,"^",4))<2 D  ;IHS/ANMC/CLS 01/20/2005
     37 .N X,X1,X2,X3
     38 .S X1=$S('$G(^DPT(DFN,.35)):DT,1:+^(.35))
     39 .S X2=$P(VAX,"^",3) Q:'X1!('X2)
     40 .D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,X<31:X_" DYS",1:X\30_" MOS")
     41 .S @VAV@($P(VAS,"^",4))=X Q
     42 ;
     43 ; End VOE addition
     44 ;
    1745 ;
    1846 ; -- expired date [6 - EX]
    … …  
    5280 S @VAV@($P(VAS,"^",12))=Y-1
    5381 Q
     82 ;
     83 ; Added for VOE to support pediatrics
     84 ;
     85PAGE ; -- IHS printable age  ;IHS/ITSC/CLS 01/14/2005
     86 N X,X1,X2,Y,AUX
     87 S X1=$S('$D(^DPT(DFN,.35)):DT,1:+^(.35))
     88 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")
     89 S @VAV@($P(VAS,"^",4))=X Q
     90 ;
     91 ; End addition for VOE & IHS
    5492 ;
    55932 ;Other Patient Variables [OPD]

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

    r628 r636  
    11VADPT2 ;ALB/MJK - ESTABLISH PATIENT VARIABLES ; 3/23/88  9:13 PM ; [10/20/95 4:02pm]
    2  ;;5.3;Registration;**69,749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;**69**;Aug 13, 1993
    335 ; -- INP call
    4  S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="" S VANOW=$$NOW^XLFDT K VAMV,VAMV0
     4 S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="" D NOW^%DTC S VANOW=% K VAMV,VAMV0
    55 I '$D(VAINDT) N VAINDT S VAINDT=VANOW
    66 S VATD=9999999.999999-VAINDT
    … …  
    5454 ;
    5555ADM ; -- send back adm ifn for dfn on vaindt or now
    56  S VADT=$S($D(VAINDT):VAINDT,1:"") I 'VADT  S VADT=$$NOW^XLFDT
     56 S VADT=$S($D(VAINDT):VAINDT,1:"") I 'VADT D NOW^%DTC S VADT=%
    5757 S VAID=9999999.999999-VADT,VADMVT=""
    5858 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)

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

    r628 r636  
    11VADPT3 ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm
    2  ;;5.3;Registration;**532,749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;**532**;Aug 13, 1993
    33 ;Inpatient variables [Version 5.0 and above]
    446 ;
    5  S (NOW,VAX("DAT"))=$$NOW^XLFDT,NOWI=9999999.999999-NOW
     5 D NOW^%DTC S (NOW,VAX("DAT"))=%,NOWI=9999999.999999-%
    66 ;
    77 I $D(VAIP("E")),$D(^DGPM(+VAIP("E"),0)) S VAX("DT")=+^(0),E=+VAIP("E") G GO ;Specific Entry

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

    r628 r636  
    11VADPT5 ;ALB/MRL/MJK - PATIENT VARIABLES [REG]; 14 DEC 1988 ; 8/6/04 7:42am
    2  ;;5.3;Registration;**54,63,242,584,749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;**54,63,242,584**;Aug 13, 1993
    3310 ;Registration/Disposition [REG]
    44 N VARPSV
    … …  
    2727 ;
    282812 ;Appointments [SDA]
    29  N VASDSV,SDCNT,SDARRAY,VANOW
    30  S VANOW=$$NOW^XLFDT
    31  S VASDSV("F")=$S($G(VASD("F"))?7N.E:VASD("F"),1:VANOW)
     29 N VASDSV,SDCNT,SDARRAY
     30 D NOW^%DTC
     31 S VASDSV("F")=$S($G(VASD("F"))?7N.E:VASD("F"),1:%)
    3232 S VASDSV("T")=$S(+$G(VASD("T")):+VASD("T"),1:9999999) I '$P(VASDSV("T"),".",2) S $P(VASDSV("T"),".",2)=999999
    3333 S VASDSV("W")=$S('$G(VASD("W")):12,1:VASD("W"))

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

    r628 r636  
    11VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
    2  ;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;;Aug 13, 1993
    33 ;
    441 ;;ID Format Enter/Edit
    … …  
    2626 ;
    2727BEG ;
    28  S VASTART=$$NOW^XLFDT
     28 D NOW^%DTC S VASTART=%
    2929 Q
    3030 ;
    3131END ;
    32  S VAEND=$$NOW^XLFDT,L=0
     32 D NOW^%DTC S VAEND=%,L=0
    3333 K XMY
    3434 S XMSUB=$P($T(OPTS+VAOPT),";",4),XMDUZ=.5,XMTEXT="VATEXT(",XMY(DUZ)=""

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

    r628 r636  
    11VAFCPID ;ALB/MLI,PKE-Create generic PID segment ; 21 Nov 2002  3:13 PM
    2  ;;5.3;Registration;**91,149,190,415,508,749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;**91,149,190,415,508**;Aug 13, 1993
    33 ;
    44 ; This routine returns the HL7 defined PID segment with its
    … …  
    2121 ;          variables may be altered.
    2222 ;
    23  N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA ; calls VADPT...have to NEW
     23 N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,VAPA ; calls VADPT...have to NEW
    2424 S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
    2525 S DFN=$G(DFN)
    … …  
    4141 S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
    4242 ;Mother's maiden name (#6)
    43  I VAFSTR[",6," D
    44  .S DGMMN("FILE")=2,DGMMN("IENS")=DFN,DGMMN("FIELD")=.2403
    45  .S X=$$HLNAME^XLFNAME(.DGMMN,"",$E(HLECH)),VAFY(6)=$S(X]"":X,1:HLQ)
     43 I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ)
    4644 ;Date of birth (#7)
    4745 I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))

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

    r628 r636  
    11VAFCTF ;BIR/DLR-Utility for capturing patient's Date Last Treated and Event Reason ;9/9/2002
    2  ;;5.3;Registration;**428,713,766**;Aug 13, 1993;Build 3
     2 ;;5.3;Registration;**428,713**;Aug 13, 1993
    33 Q  ; quit if called from the top
    44 ;
    … …  
    7171 . Q
    7272 K VAFCDATA,VAFCPURG,VAFCX,VAFCX1,VAFCX2
    73  ;DG*5.3*766
    74  I $E(VAFCX3,9,10)>23 S VAFCX3=$E(VAFCX3,1,8)_"23"_$E(VAFCX3,11,14)
    75  I $E(VAFCX3,11)>5 S VAFCX3=$E(VAFCX3,1,10)_"59"_$E(VAFCX3,13,14)
    76  ;DG*5.3*713
    7773 I $E(VAFCX3,13)>5 S VAFCX3=$E(VAFCX3,1,12)_"59"
    7874 Q VAFCX3_"^5" ; X is either null or the date/time of the check out

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

    r628 r636  
    11VAFHLPID ;ALB/MLI/ESD - Create generic PID segment ; 21 Nov 2002  3:13 PM
    2  ;;5.3;Registration;**68,94,415,508,749**;Aug 13, 1993;Build 10
     2 ;;5.3;Registration;**68,94,415,508**;Aug 13, 1993
    33 ;
    44 ; This routine returns the HL7 defined PID segment with its
    … …  
    2626 ;          variables may be altered.
    2727 ;
    28  N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA ; calls VADPT...have to NEW
     28 N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,VAPA ; calls VADPT...have to NEW
    2929 S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
    3030 S DFN=$G(DFN)
    … …  
    5050 S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
    5151 ;Mother's maiden name (#6)
    52  I VAFSTR[",6," D
    53  .S DGMMN("FILE")=2,DGMMN("IENS")=DFN,DGMMN("FIELD")=.2403
    54  .S X=$$HLNAME^XLFNAME(.DGMMN,"",$E(HLECH)),VAFY(6)=$S(X]"":X,1:HLQ)
     52 I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ)
    5553 ;Date of birth (#7)
    5654 I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))

  • FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPR1.m

    r628 r636  
    11VAFHLPR1 ;ALB/ESD - Create generic HL7 PR1 Segment ;4/4/00
    2  ;;5.3;Registration;**94,123,160,215,243,606**;Aug 13, 1993
     2 ;;5.3;Registration;**94,123,160,215,243,606**;Aug 13, 1993;Build 1
    33 ;06/22/99 ACS - Added CPT modifier API calls and added CPT modifier to the
    44 ;PR1 segment (sequence 16)
Note: See TracChangeset for help on using the changeset viewer.