Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: EASECDEL

EASECDEL.m

Go to the documentation of this file. 
  1. EASECDEL ;ALB/LBD - Delete a LTC Copay Test;  2 JUN 2003
  1.  ;;1.0;ENROLLMENT APPLICATION SYSTEM;**34**;Mar 15, 2001
  1.  ;
  1. EN ; Entry point to delete a LTC copay test
  1.  I '$D(^XUSEC("DG MTDELETE",+DUZ)) W !!,"ACCESS TO THIS OPTION IS RESTRICTED!!",*7 G EXIT
  1.  ;
  1. LKP ; Patient lookup
  1.  N DIC,DTOUT,DUOUT,DGMTYPT,DGNAM,DGDOB,VA,Y
  1.  S DGMTYPT=3
  1.  D HOME^%ZIS S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC G:$D(DTOUT)!($D(DUOUT))!(+Y<0) EXIT
  1.  I '$O(^DGMT(408.31,"AD",DGMTYPT,+Y,0)) W !?5,$P(Y(0),U)," has no LTC copay (10-10EC) tests on file." G LKP
  1.  S DFN=+Y,DGNAM=$P(Y(0),U),DGDOB=$P(Y(0),U,3)
  1.  D HD
  1.  ;
  1. LKT ; LTC Copay Test lookup
  1.  N D,DIC,DGMTI,DGMTDT,DIR,X,Y
  1.  S DIC("W")="D ID^EASECDEL",DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
  1.  W ! S DIC="^DGMT(408.31,",DIC(0)="EQZ",X=DFN,D="C" D IX^DIC K DIC
  1.  I $D(DTOUT)!($D(DUOUT))!(+Y<0) G LKP
  1.  I '$P($G(^DG(408.34,+$P(Y(0),U,23),0)),U,2) W !,?5,"This LTC Copay Test (10-10EC) is uneditable and cannot be deleted." G LKP
  1.  S DGMTI=+Y,DGMTDT=$P(Y(0),U)
  1.  S DIR(0)="Y",DIR("A")="Display test",DIR("B")="YES"
  1.  D ^DIR K DIR I Y D HD,DISPLAY^EASECU23(DGMTI,DGMTYPT)
  1.  S DIR(0)="Y",DIR("A")="Are you sure you want to delete the "_$$FMTE^XLFDT(DGMTDT,1)_" test",DIR("B")="NO"
  1.  W ! D ^DIR K DIR I Y'=1 W !,"    <OK, nothing deleted!>" G LKP
  1.  D DEL(DGMTI,DFN) W !,"  <LTC Copay Test deleted.>"
  1.  G LKP
  1. EXIT Q
  1.  ;
  1. DEL(DGMTI,DFN) ; Delete selected LTC Copay Test from Annual Means Test file
  1.  ; #408.31 and all entries that point to it in the Individual Annual
  1.  ; Income file #408.21 and the Income Relations file #408.22.
  1.  ; INPUT - DGMTI  IEN of LTC Copay Test to delete from file #408.31
  1.  ;         DFN  IEN of Patient file #2
  1.  ; OUTPUT - none
  1.  N DIK,DA,DGX,DGY,LTC4
  1.  S LTC4=$P($G(^DGMT(408.31,DGMTI,2)),U,8)
  1.  S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK K DIK
  1.  S DIK="^DGMT(408.22,",DGY=0
  1.  F  S DGY=$O(^DGMT(408.22,"AMT",DGMTI,DFN,DGY)) Q:'DGY  S DGX=0 F  S DGX=$O(^DGMT(408.22,"AMT",DGMTI,DFN,DGY,DGX)) Q:'DGX  S DA=DGX D ^DIK
  1.  S DGX=0
  1.  F  S DGX=$O(^DGMT(408.21,"AM",DGMTI,DGX)) Q:'DGX  S DIK="^DGMT(408.21,",DA=DGX D ^DIK D
  1.  .S DGY=0 F  S DGY=$O(^DGMT(408.22,"AIND",DGX,DGY)) Q:'DGY  S DIK="^DGMT(408.22,",DA=DGY D ^DIK
  1.  ; Delete associated LTC Copay Exemption test (type 4) if it's
  1.  ; not associated with any other LTC Copay test.
  1.  Q:'LTC4  Q:$O(^DGMT(408.31,"AT",LTC4,""))
  1.  D DEL4(LTC4)
  1.  Q
  1.  ;
  1. DEL4(LTC4) ; Delete LTC Copay Exemption Test (type 4) associated with
  1.  ; LTC Copay Test. Update IVM Patient file to send deletion to HEC.
  1.  ; INPUT - LTC4   IEN of LTC Copay Exemption Test to delete from #408.31
  1.  N DGMTDT,DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT
  1.  S DGMTI=$G(LTC4) Q:'DGMTI
  1.  S DGMTDT=$P($G(^DGMT(408.31,DGMTI,0)),U) Q:'DGMTDT
  1.  S DGMTP=$G(^DGMT(408.31,DGMTI,0))
  1.  D DELETE^IVMPLOG(DFN,DGMTDT,,,,4)
  1.  S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK
  1.  S DGMTACT="DEL" D AFTER^DGMTEVT
  1.  S DGMTYPT=4,DGMTINF=1 D EN^DGMTAUD
  1.  D ^IVMPMTE
  1.  Q
  1. HD ; Writes patient header to the screen
  1.  W @IOF,"Name: ",DGNAM,?40,"DOB: ",$$FMTE^XLFDT(DGDOB),?65,"Pat ID: ",$$PID(DFN),!!!
  1.  Q
  1.  ;
  1. PID(DFN) ; Return PID
  1.  ; INPUT  - DFN
  1.  ; OUTPUT - PID or 'UNKNOWN'
  1.  D PID^VADPT6
  1.  Q $S(VA("PID")]"":VA("PID"),1:"UNKNOWN")
  1.  ;
  1. ID ; Write identifiers for test lookup
  1.  N DGI,DGN
  1.  S DGI=Y,DGN=$G(^DGMT(408.31,DGI,0))
  1.  W "  LTC Copay Test Date   Status: ",$$S^DGMTAUD1($P(^(0),U,3))
  1.  W !?36,"Source: ",$$SR^DGMTAUD1(DGN)
  1.  Q