source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASECDEL.m@ 1169

Last change on this file since 1169 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.2 KB
Line 
1EASECDEL ;ALB/LBD - Delete a LTC Copay Test; 2 JUN 2003
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**34**;Mar 15, 2001
3 ;
4EN ; Entry point to delete a LTC copay test
5 I '$D(^XUSEC("DG MTDELETE",+DUZ)) W !!,"ACCESS TO THIS OPTION IS RESTRICTED!!",*7 G EXIT
6 ;
7LKP ; Patient lookup
8 N DIC,DTOUT,DUOUT,DGMTYPT,DGNAM,DGDOB,VA,Y
9 S DGMTYPT=3
10 D HOME^%ZIS S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC G:$D(DTOUT)!($D(DUOUT))!(+Y<0) EXIT
11 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
12 S DFN=+Y,DGNAM=$P(Y(0),U),DGDOB=$P(Y(0),U,3)
13 D HD
14 ;
15LKT ; LTC Copay Test lookup
16 N D,DIC,DGMTI,DGMTDT,DIR,X,Y
17 S DIC("W")="D ID^EASECDEL",DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
18 W ! S DIC="^DGMT(408.31,",DIC(0)="EQZ",X=DFN,D="C" D IX^DIC K DIC
19 I $D(DTOUT)!($D(DUOUT))!(+Y<0) G LKP
20 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
21 S DGMTI=+Y,DGMTDT=$P(Y(0),U)
22 S DIR(0)="Y",DIR("A")="Display test",DIR("B")="YES"
23 D ^DIR K DIR I Y D HD,DISPLAY^EASECU23(DGMTI,DGMTYPT)
24 S DIR(0)="Y",DIR("A")="Are you sure you want to delete the "_$$FMTE^XLFDT(DGMTDT,1)_" test",DIR("B")="NO"
25 W ! D ^DIR K DIR I Y'=1 W !," <OK, nothing deleted!>" G LKP
26 D DEL(DGMTI,DFN) W !," <LTC Copay Test deleted.>"
27 G LKP
28EXIT Q
29 ;
30DEL(DGMTI,DFN) ; Delete selected LTC Copay Test from Annual Means Test file
31 ; #408.31 and all entries that point to it in the Individual Annual
32 ; Income file #408.21 and the Income Relations file #408.22.
33 ; INPUT - DGMTI IEN of LTC Copay Test to delete from file #408.31
34 ; DFN IEN of Patient file #2
35 ; OUTPUT - none
36 N DIK,DA,DGX,DGY,LTC4
37 S LTC4=$P($G(^DGMT(408.31,DGMTI,2)),U,8)
38 S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK K DIK
39 S DIK="^DGMT(408.22,",DGY=0
40 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
41 S DGX=0
42 F S DGX=$O(^DGMT(408.21,"AM",DGMTI,DGX)) Q:'DGX S DIK="^DGMT(408.21,",DA=DGX D ^DIK D
43 .S DGY=0 F S DGY=$O(^DGMT(408.22,"AIND",DGX,DGY)) Q:'DGY S DIK="^DGMT(408.22,",DA=DGY D ^DIK
44 ; Delete associated LTC Copay Exemption test (type 4) if it's
45 ; not associated with any other LTC Copay test.
46 Q:'LTC4 Q:$O(^DGMT(408.31,"AT",LTC4,""))
47 D DEL4(LTC4)
48 Q
49 ;
50DEL4(LTC4) ; Delete LTC Copay Exemption Test (type 4) associated with
51 ; LTC Copay Test. Update IVM Patient file to send deletion to HEC.
52 ; INPUT - LTC4 IEN of LTC Copay Exemption Test to delete from #408.31
53 N DGMTDT,DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT
54 S DGMTI=$G(LTC4) Q:'DGMTI
55 S DGMTDT=$P($G(^DGMT(408.31,DGMTI,0)),U) Q:'DGMTDT
56 S DGMTP=$G(^DGMT(408.31,DGMTI,0))
57 D DELETE^IVMPLOG(DFN,DGMTDT,,,,4)
58 S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK
59 S DGMTACT="DEL" D AFTER^DGMTEVT
60 S DGMTYPT=4,DGMTINF=1 D EN^DGMTAUD
61 D ^IVMPMTE
62 Q
63HD ; Writes patient header to the screen
64 W @IOF,"Name: ",DGNAM,?40,"DOB: ",$$FMTE^XLFDT(DGDOB),?65,"Pat ID: ",$$PID(DFN),!!!
65 Q
66 ;
67PID(DFN) ; Return PID
68 ; INPUT - DFN
69 ; OUTPUT - PID or 'UNKNOWN'
70 D PID^VADPT6
71 Q $S(VA("PID")]"":VA("PID"),1:"UNKNOWN")
72 ;
73ID ; Write identifiers for test lookup
74 N DGI,DGN
75 S DGI=Y,DGN=$G(^DGMT(408.31,DGI,0))
76 W " LTC Copay Test Date Status: ",$$S^DGMTAUD1($P(^(0),U,3))
77 W !?36,"Source: ",$$SR^DGMTAUD1(DGN)
78 Q
Note: See TracBrowser for help on using the repository browser.