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

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

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

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

@@ -1 @@
-DG10    ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 1/5/2006  21:46
-        ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 30
-        ; Modified from FOIA VISTA,
-        ; Copyright (C) 2007 WorldVistA
-        ;
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ;
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ;
-        ; You should have received a copy of the GNU General Public License
-        ; along with this program; if not, write to the Free Software
-        ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-START   ;
-        D LO^DGUTL
-        I $G(DGPRFLG)=1,$G(DGPLOC)=1 D  G Q:$G(DGRPOUT),A1
-        .; D EN^DGRPD,REG^IVMCQ($G(DFN))
-        . D EN^DGRPD
-        . Q:$G(DGRPOUT)
-        . ;
-        . ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
-        . ;
-        . ; HEC query call only wanted/needed for VA agency code
-        . ;
-        . I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
-        . ;
-        . ; ** end of VOE change 1 **
-        . ;
-        . D HINQ
-        ;
-A       W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
-        N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
-        ;
-        ;MPI QUERY
-        ;check to see if CIRN PD/MPI is installed
-        N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
-        K MPIFRTN
-        ;
-        ; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
-        ;
-        ; MPI query call only wanted/needed for VA agency code
-        ;
-        I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
-        ;
-        ; ** end of VOE change 2 **
-        ;
-        K MPIFRTN
-        ;
-        I +$G(DGNEW) D
-        . ; query CMOR for Patient Record Flag Assignments if NEW patient and
-        . ; display results
-        . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
-        ;
-SKIP    ;
-        S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
-        ;
-        ; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
-        ;
-        ; these query calls only wanted/needed for VA agency code
-        ;
-        I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
-        G A1
-        ;
-        ; ** end of VOE change 3 **
-        ;
-        ;
-HINQ    ;
-        S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D
-        .N DGROUT
-        .S DGROUT=X
-        .I $G(DFN) D
-        ..N X,Y,DGRP
-        ..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X))
-        ..W !,"     Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
-        ..W ?40,"   Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
-        .D @("EN^"_DGROUT) K Y Q  ;from dgdem0
-        Q
-        ;
-        ;   SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management 
-        ;   to bypass the embossing routines when calling load/edit from IEMM
-        ;
-A1      D  G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP,MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS
-        .W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data"
-        .S %=1 D YN^DICN
-        .I +$G(DGNEW) Q
-        .I $$ADD^DGADDUTL($G(DFN)) ;
-        ;
-H       W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
-        G A1
-        ;
-CK      S DGEDCN=1 D ^DGRPC,MT(DFN),CP
-        G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM)
-        I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR
-        ;G:Y ^DGRP9
-        ;
-EMBOS   ;W ! D EMBOS^DGQEMA G A
-        G A
-        ;
-        ;
-Q       K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,VET Q
-        ;
-MT(DFN) ; Check if user requires a means test.  Ask user if they want to proceedif
-        ; one is required
-        I '$D(SDIEMM) DO
-        .N DGREQF,DIV
-        .D EN^DGMTR
-        .I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
-        .Q
-        I $D(SDIEMM) DO
-        .N DGMTI
-        .S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
-        .I $P(DGMTI,U,4)="R" D  I 1
-        ..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^")
-        ..I '$$OKTOCONT(DGMTDT) Q
-        ..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC
-        .E  D WARNING
-        .Q
-        Q
-        ;
-WARNING ;
-        ;prints a warning to the screen about means test
-        ;
-        W !!,"A means test for this encounter date was not found and may be required!"
-        W !,"Further investigation will be needed."
-        W !
-        D PAUSE
-        Q
-        ;
-PAUSE   ;
-        N DIR
-        S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR
-        Q
-        ;
-OKTOCONT(Y)     ;
-        ;
-        N DIR
-        W !!,"Patient Requires a means Test"
-        X ^DD("DD")
-        W !,"Primary Means Test Required from '",Y,"'",!
-        ;
-        I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO  G OKQ
-        .W !,$C(7),"You do not have the appropriate IEMM Security Key.  Contact your supervisor.",!
-        .D PAUSE
-        .S Y=0
-        ;
-        S DIR("A")="Do you wish to proceed with the means test at this time"
-        S DIR("B")="YES"
-        S DIR(0)="Y"
-        D ^DIR
-OKQ     Q $S(Y=1:1,1:0)
-        ;
-CP      ;If not (autoexempt or MTested) & no CP test this year then
-        ;prompt for add/edit cp test
-        N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
-        G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
-        S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
-        D EN^DGMTCOR
-        I +$G(DGNOCOPF) S DGMTCOR=0
-        I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
-        K DGNOCOPF
-QTCP    Q
+DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 1/5/2006  21:46
+ ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+START ;
+ D LO^DGUTL
+ I $G(DGPRFLG)=1,$G(DGPLOC)=1 D  G Q:$G(DGRPOUT),A1
+ .; D EN^DGRPD,REG^IVMCQ($G(DFN))
+ . D EN^DGRPD
+ . Q:$G(DGRPOUT)
+ . ;
+ . ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ . ;
+ . ; HEC query call only wanted/needed for VA agency code
+ . ;
+ . I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
+ . ;
+ . ; ** end of VOE change 1 **
+ . ;
+ . D HINQ
+ ;
+A W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
+ N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
+ ;
+ ;MPI QUERY
+ ;check to see if CIRN PD/MPI is installed
+ N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
+ K MPIFRTN
+ ;
+ ; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; MPI query call only wanted/needed for VA agency code
+ ;
+ I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
+ ;
+ ; ** end of VOE change 2 **
+ ;
+ K MPIFRTN
+ ;
+ I +$G(DGNEW) D
+ . ; query CMOR for Patient Record Flag Assignments if NEW patient and
+ . ; display results
+ . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
+ ;
+SKIP ;
+ S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
+ ;
+ ; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; these query calls only wanted/needed for VA agency code
+ ;
+ I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
+ G A1
+ ;
+ ; ** end of VOE change 3 **
+ ;
+ ;
+HINQ ;
+ S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D
+ .N DGROUT
+ .S DGROUT=X
+ .I $G(DFN) D
+ ..N X,Y,DGRP
+ ..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X))
+ ..W !,"     Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
+ ..W ?40,"   Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
+ .D @("EN^"_DGROUT) K Y Q  ;from dgdem0
+ Q
+ ;
+ ;   SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management 
+ ;   to bypass the embossing routines when calling load/edit from IEMM
+ ;
+A1 D  G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP,MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS
+ .W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data"
+ .S %=1 D YN^DICN
+ .I +$G(DGNEW) Q
+ .I $$ADD^DGADDUTL($G(DFN)) ;
+ ;
+H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
+ G A1
+ ;
+CK S DGEDCN=1 D ^DGRPC,MT(DFN),CP
+ G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM)
+ I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR
+ ;G:Y ^DGRP9
+ ;
+EMBOS ;W ! D EMBOS^DGQEMA G A
+ G A
+ ;
+ ;
+Q K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,VET Q
+ ;
+MT(DFN) ; Check if user requires a means test.  Ask user if they want to proceedif
+ ; one is required
+ I '$D(SDIEMM) DO
+ .N DGREQF,DIV
+ .D EN^DGMTR
+ .I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
+ .Q
+ I $D(SDIEMM) DO
+ .N DGMTI
+ .S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
+ .I $P(DGMTI,U,4)="R" D  I 1
+ ..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^")
+ ..I '$$OKTOCONT(DGMTDT) Q
+ ..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC
+ .E  D WARNING
+ .Q
+ Q
+ ;
+WARNING ;
+ ;prints a warning to the screen about means test
+ ;
+ W !!,"A means test for this encounter date was not found and may be required!"
+ W !,"Further investigation will be needed."
+ W !
+ D PAUSE
+ Q
+ ;
+PAUSE ;
+ N DIR
+ S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR
+ Q
+ ;
+OKTOCONT(Y) ;
+ ;
+ N DIR
+ W !!,"Patient Requires a means Test"
+ X ^DD("DD")
+ W !,"Primary Means Test Required from '",Y,"'",!
+ ;
+ I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO  G OKQ
+ .W !,$C(7),"You do not have the appropriate IEMM Security Key.  Contact your supervisor.",!
+ .D PAUSE
+ .S Y=0
+ ;
+ S DIR("A")="Do you wish to proceed with the means test at this time"
+ S DIR("B")="YES"
+ S DIR(0)="Y"
+ D ^DIR
+OKQ Q $S(Y=1:1,1:0)
+ ;
+CP ;If not (autoexempt or MTested) & no CP test this year then
+ ;prompt for add/edit cp test
+ N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
+ G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
+ S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
+ D EN^DGMTCOR
+ I +$G(DGNOCOPF) S DGMTCOR=0
+ I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
+ K DGNOCOPF
+QTCP Q