source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTDEL1.m@ 1141

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1DGMTDEL1 ;ALB/CAW,LBD,PHH - Delete MT for a Patient (con't) ;12/6/94
2 ;;5.3;Registration;**45,166,182,433,518,531**;Aug 13, 1993
3 ;
4ID ;write identifiers
5 S DGI=Y,DGN=$G(^DGMT(408.31,DGI,0))
6 W ?21,$S(DGMTYPT=1:"MEANS",DGMTYPT=2:"COPAY",DGMTYPT=4:"LTC Copay Exemption",1:"")_" TEST DATE"
7 S DGMTSRC=$$SR^DGMTAUD1(DGN)
8 I DGMTSRC="" S DGMTSRC="UNKNOWN"
9 W ?40,"SOURCE: ",$S($L(DGMTSRC)>10:$E(DGMTSRC,1,10),1:DGMTSRC),?60,"PRIMARY TEST: ",$S($G(^DGMT(408.31,DGI,"PRIM"))=1:"YES",1:"NO")
10 W !?14,"STATUS: ",$$S^DGMTAUD1($P(^(0),U,3)),?45,"COMPLETED: ",$S($P(^DGMT(408.31,DGI,0),U,7)']"":"-----",1:$$DATE($P(^(0),U,7)))
11 Q
12 ;
13DEL ;delete
14 ;
15 ;add entry in IVM PATIENT file used to notify HEC that a Means Test
16 ;or Copay, or LTC Copay Exemption Test has been deleted.
17 ;
18 D DELETE^IVMPLOG(DFN,DGMTD,$S(DGMTYPT=1:1,1:""),$S(DGMTYPT=2:2,1:""),,$S(DGMTYPT=4:4,1:""))
19 ;
20 D DELLNK ;Deletion of Linked Tests
21 S DGMTACT="DEL",DIK="^DGMT(408.31," D ^DIK
22 S DGMTY=0 F S DGMTY=$O(^DGMT(408.22,"AMT",DGMTI,DFN,DGMTY)) Q:'DGMTY S DGMTX=0 F S DGMTX=$O(^DGMT(408.22,"AMT",DGMTI,DFN,DGMTY,DGMTX)) Q:'DGMTX D
23 .S DA=DGMTX
24 .I DA S DR="31///@",DIE="^DGMT(408.22," D ^DIE
25 .K DE,DQ,DR,DIK
26 .;
27 .; Delete the $0.00 values out of the net worth fields if total income
28 .; is not greater than zero dollars.
29 .N DA,NODE0,AMTFLG,CNT,DIE,DR
30 .S DA=$P($G(^DGMT(408.22,DGMTX,0)),"^",2)
31 .I DA D
32 ..Q:'$D(^DGMT(408.21,DA,2))
33 ..S NODE0=$G(^DGMT(408.21,DA,0)) Q:NODE0=""
34 ..S AMTFLG=0 F CNT=0:1:9 S:$P(NODE0,"^",CNT+8)'="" AMTFLG=1
35 ..I 'AMTFLG S DIE="^DGMT(408.21,",DR="31///@;2.01///@;2.02///@;2.03///@;2.04///@" D ^DIE
36 D AFTER^DGMTEVT S DGMTINF=0
37 I DGMTYPT=1!(DGMTYPT=2) D EN^DGMTEVT
38 I DGMTYPT=4 D
39 . D EN^DGMTAUD
40 . D ^IVMPMTE
41 Q
42VAR ;set variables
43 S DA=DGMTI,(DGP,DGMTP)=DGMT0,DGMTD=$P(DGMT0,U),DGCAT=$$MTS^DGMTU(DFN,$P(DGMTP,U,3)),DGMTYPT=$P(^DGMT(408.31,DGMTI,0),U,19)
44 Q
45LOOP ;loop through all means test for patient and delete
46 S (DGCT,DGI)=0 F S DGI=$O(^DGMT(408.31,"C",DFN,DGI)) G:'DGI LKP^DGMTDEL S DGMTI=DGI,DGMT0=+$G(^DGMT(408.31,DGMTI,0)) D VAR,DEL S DGMTP=DGP,DGCT=DGCT+1
47 W !?10,DGCT,$S(DGMTYPT=1:" Means Test",DGMTYPT=2:" Copay Test",DGMTYPT=4:" LTC Copay Exemption Test",1:"")_$S(DGCT'=1:"s",1:"")_" deleted!"
48 Q
49DATE(X) ;function to return date in external format
50 ;INPUT - FM internal date format
51 ;OUTPUT - external date format
52 Q $$FMTE^XLFDT($E(X,1,12),1)
53 ;
54PID(X) ;function to return pid
55 ;INPUT - DFN
56 ;OUTPUT - PID or UNKNOWN
57 D PID^VADPT6
58 Q $S(VA("PID")]"":VA("PID"),1:"UNKNOWN")
59DELLNK ;Deletion of Linked tests
60 N IEN4,GIEN,DA,DIK,DIE,DR,LTCDT
61 I DGMTYPT=1!(DGMTYPT=2) D
62 .;check to see if test type 4 is linked with type 1 or 2
63 . S IEN4=$O(^DGMT(408.31,"AT",DGMTI,"")) Q:IEN4="" ;Test type 4
64 . S LTCDT=$P($G(^DGMT(408.31,IEN4,0)),"^",1) ;Date of Test
65 .;Check to see if test type 3 is linked with type 4
66 .;if linked, remove pointer value from test type 3
67 .; Added FOR loop for LTC Phase III to support multiple type 3 tests
68 . S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",IEN4,GIEN)) Q:GIEN="" D
69 . . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DIE
70 .;remove linked test type 4 record.
71 . D DELETE^IVMPLOG(DFN,LTCDT,,,,4)
72 . N DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT
73 . S DGMTI=IEN4,DGMTP=$G(^DGMT(408.31,DGMTI,0))
74 . S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK
75 . S DGMTACT="DEL" D AFTER^DGMTEVT S DGMTINF=0
76 . S DGMTYPT=4 D EN^DGMTAUD
77 I DGMTYPT=4 D
78 .;Check to see if test type 3 is linked with type 4
79 .;if linked, remove pointer value from test type 3
80 .; Added FOR loop for LTC Phase III to support multiple type 3 tests
81 . S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",DGMTI,GIEN)) Q:GIEN="" D
82 . . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DIE
83 Q
Note: See TracBrowser for help on using the repository browser.