DGMTDEL1 ;ALB/CAW,LBD,PHH - Delete MT for a Patient (con't) ;12/6/94
;;5.3;Registration;**45,166,182,433,518,531**;Aug 13, 1993
;
ID ;write identifiers
S DGI=Y,DGN=$G(^DGMT(408.31,DGI,0))
W ?21,$S(DGMTYPT=1:"MEANS",DGMTYPT=2:"COPAY",DGMTYPT=4:"LTC Copay Exemption",1:"")_" TEST DATE"
S DGMTSRC=$$SR^DGMTAUD1(DGN)
I DGMTSRC="" S DGMTSRC="UNKNOWN"
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")
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)))
Q
;
DEL ;delete
;
;add entry in IVM PATIENT file used to notify HEC that a Means Test
;or Copay, or LTC Copay Exemption Test has been deleted.
;
D DELETE^IVMPLOG(DFN,DGMTD,$S(DGMTYPT=1:1,1:""),$S(DGMTYPT=2:2,1:""),,$S(DGMTYPT=4:4,1:""))
;
D DELLNK ;Deletion of Linked Tests
S DGMTACT="DEL",DIK="^DGMT(408.31," D ^DIK
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
.S DA=DGMTX
.I DA S DR="31///@",DIE="^DGMT(408.22," D ^DIE
.K DE,DQ,DR,DIK
.;
.; Delete the $0.00 values out of the net worth fields if total income
.; is not greater than zero dollars.
.N DA,NODE0,AMTFLG,CNT,DIE,DR
.S DA=$P($G(^DGMT(408.22,DGMTX,0)),"^",2)
.I DA D
..Q:'$D(^DGMT(408.21,DA,2))
..S NODE0=$G(^DGMT(408.21,DA,0)) Q:NODE0=""
..S AMTFLG=0 F CNT=0:1:9 S:$P(NODE0,"^",CNT+8)'="" AMTFLG=1
..I 'AMTFLG S DIE="^DGMT(408.21,",DR="31///@;2.01///@;2.02///@;2.03///@;2.04///@" D ^DIE
D AFTER^DGMTEVT S DGMTINF=0
I DGMTYPT=1!(DGMTYPT=2) D EN^DGMTEVT
I DGMTYPT=4 D
. D EN^DGMTAUD
. D ^IVMPMTE
Q
VAR ;set variables
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)
Q
LOOP ;loop through all means test for patient and delete
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
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!"
Q
DATE(X) ;function to return date in external format
;INPUT - FM internal date format
;OUTPUT - external date format
Q $$FMTE^XLFDT($E(X,1,12),1)
;
PID(X) ;function to return pid
;INPUT - DFN
;OUTPUT - PID or UNKNOWN
D PID^VADPT6
Q $S(VA("PID")]"":VA("PID"),1:"UNKNOWN")
DELLNK ;Deletion of Linked tests
N IEN4,GIEN,DA,DIK,DIE,DR,LTCDT
I DGMTYPT=1!(DGMTYPT=2) D
.;check to see if test type 4 is linked with type 1 or 2
. S IEN4=$O(^DGMT(408.31,"AT",DGMTI,"")) Q:IEN4="" ;Test type 4
. S LTCDT=$P($G(^DGMT(408.31,IEN4,0)),"^",1) ;Date of Test
.;Check to see if test type 3 is linked with type 4
.;if linked, remove pointer value from test type 3
.; Added FOR loop for LTC Phase III to support multiple type 3 tests
. S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",IEN4,GIEN)) Q:GIEN="" D
. . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DIE
.;remove linked test type 4 record.
. D DELETE^IVMPLOG(DFN,LTCDT,,,,4)
. N DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT
. S DGMTI=IEN4,DGMTP=$G(^DGMT(408.31,DGMTI,0))
. S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK
. S DGMTACT="DEL" D AFTER^DGMTEVT S DGMTINF=0
. S DGMTYPT=4 D EN^DGMTAUD
I DGMTYPT=4 D
.;Check to see if test type 3 is linked with type 4
.;if linked, remove pointer value from test type 3
.; Added FOR loop for LTC Phase III to support multiple type 3 tests
. S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",DGMTI,GIEN)) Q:GIEN="" D
. . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTDEL1 3756 printed Nov 22, 2024@17:54:48 Page 2
DGMTDEL1 ;ALB/CAW,LBD,PHH - Delete MT for a Patient (con't) ;12/6/94
+1 ;;5.3;Registration;**45,166,182,433,518,531**;Aug 13, 1993
+2 ;
ID ;write identifiers
+1 SET DGI=Y
SET DGN=$GET(^DGMT(408.31,DGI,0))
+2 WRITE ?21,$SELECT(DGMTYPT=1:"MEANS",DGMTYPT=2:"COPAY",DGMTYPT=4:"LTC Copay Exemption",1:"")_" TEST DATE"
+3 SET DGMTSRC=$$SR^DGMTAUD1(DGN)
+4 IF DGMTSRC=""
SET DGMTSRC="UNKNOWN"
+5 WRITE ?40,"SOURCE: ",$SELECT($LENGTH(DGMTSRC)>10:$EXTRACT(DGMTSRC,1,10),1:DGMTSRC),?60,"PRIMARY TEST: ",$SELECT($GET(^DGMT(408.31,DGI,"PRIM"))=1:"YES",1:"NO")
+6 WRITE !?14,"STATUS: ",$$S^DGMTAUD1($PIECE(^(0),U,3)),?45,"COMPLETED: ",$SELECT($PIECE(^DGMT(408.31,DGI,0),U,7)']"":"-----",1:$$DATE($PIECE(^(0),U,7)))
+7 QUIT
+8 ;
DEL ;delete
+1 ;
+2 ;add entry in IVM PATIENT file used to notify HEC that a Means Test
+3 ;or Copay, or LTC Copay Exemption Test has been deleted.
+4 ;
+5 DO DELETE^IVMPLOG(DFN,DGMTD,$SELECT(DGMTYPT=1:1,1:""),$SELECT(DGMTYPT=2:2,1:""),,$SELECT(DGMTYPT=4:4,1:""))
+6 ;
+7 ;Deletion of Linked Tests
DO DELLNK
+8 SET DGMTACT="DEL"
SET DIK="^DGMT(408.31,"
DO ^DIK
+9 SET DGMTY=0
FOR
SET DGMTY=$ORDER(^DGMT(408.22,"AMT",DGMTI,DFN,DGMTY))
if 'DGMTY
QUIT
SET DGMTX=0
FOR
SET DGMTX=$ORDER(^DGMT(408.22,"AMT",DGMTI,DFN,DGMTY,DGMTX))
if 'DGMTX
QUIT
Begin DoDot:1
+10 SET DA=DGMTX
+11 IF DA
SET DR="31///@"
SET DIE="^DGMT(408.22,"
DO ^DIE
+12 KILL DE,DQ,DR,DIK
+13 ;
+14 ; Delete the $0.00 values out of the net worth fields if total income
+15 ; is not greater than zero dollars.
+16 NEW DA,NODE0,AMTFLG,CNT,DIE,DR
+17 SET DA=$PIECE($GET(^DGMT(408.22,DGMTX,0)),"^",2)
+18 IF DA
Begin DoDot:2
+19 if '$DATA(^DGMT(408.21,DA,2))
QUIT
+20 SET NODE0=$GET(^DGMT(408.21,DA,0))
if NODE0=""
QUIT
+21 SET AMTFLG=0
FOR CNT=0:1:9
if $PIECE(NODE0,"^",CNT+8)'=""
SET AMTFLG=1
+22 IF 'AMTFLG
SET DIE="^DGMT(408.21,"
SET DR="31///@;2.01///@;2.02///@;2.03///@;2.04///@"
DO ^DIE
End DoDot:2
End DoDot:1
+23 DO AFTER^DGMTEVT
SET DGMTINF=0
+24 IF DGMTYPT=1!(DGMTYPT=2)
DO EN^DGMTEVT
+25 IF DGMTYPT=4
Begin DoDot:1
+26 DO EN^DGMTAUD
+27 DO ^IVMPMTE
End DoDot:1
+28 QUIT
VAR ;set variables
+1 SET DA=DGMTI
SET (DGP,DGMTP)=DGMT0
SET DGMTD=$PIECE(DGMT0,U)
SET DGCAT=$$MTS^DGMTU(DFN,$PIECE(DGMTP,U,3))
SET DGMTYPT=$PIECE(^DGMT(408.31,DGMTI,0),U,19)
+2 QUIT
LOOP ;loop through all means test for patient and delete
+1 SET (DGCT,DGI)=0
FOR
SET DGI=$ORDER(^DGMT(408.31,"C",DFN,DGI))
if 'DGI
GOTO LKP^DGMTDEL
SET DGMTI=DGI
SET DGMT0=+$GET(^DGMT(408.31,DGMTI,0))
DO VAR
DO DEL
SET DGMTP=DGP
SET DGCT=DGCT+1
+2 WRITE !?10,DGCT,$SELECT(DGMTYPT=1:" Means Test",DGMTYPT=2:" Copay Test",DGMTYPT=4:" LTC Copay Exemption Test",1:"")_$SELECT(DGCT'=1:"s",1:"")_" deleted!"
+3 QUIT
DATE(X) ;function to return date in external format
+1 ;INPUT - FM internal date format
+2 ;OUTPUT - external date format
+3 QUIT $$FMTE^XLFDT($EXTRACT(X,1,12),1)
+4 ;
PID(X) ;function to return pid
+1 ;INPUT - DFN
+2 ;OUTPUT - PID or UNKNOWN
+3 DO PID^VADPT6
+4 QUIT $SELECT(VA("PID")]"":VA("PID"),1:"UNKNOWN")
DELLNK ;Deletion of Linked tests
+1 NEW IEN4,GIEN,DA,DIK,DIE,DR,LTCDT
+2 IF DGMTYPT=1!(DGMTYPT=2)
Begin DoDot:1
+3 ;check to see if test type 4 is linked with type 1 or 2
+4 ;Test type 4
SET IEN4=$ORDER(^DGMT(408.31,"AT",DGMTI,""))
if IEN4=""
QUIT
+5 ;Date of Test
SET LTCDT=$PIECE($GET(^DGMT(408.31,IEN4,0)),"^",1)
+6 ;Check to see if test type 3 is linked with type 4
+7 ;if linked, remove pointer value from test type 3
+8 ; Added FOR loop for LTC Phase III to support multiple type 3 tests
+9 SET GIEN=""
FOR
SET GIEN=$ORDER(^DGMT(408.31,"AT",IEN4,GIEN))
if GIEN=""
QUIT
Begin DoDot:2
+10 SET DA=GIEN
SET DR="2.08///@"
SET DIE="^DGMT(408.31,"
DO ^DIE
End DoDot:2
+11 ;remove linked test type 4 record.
+12 DO DELETE^IVMPLOG(DFN,LTCDT,,,,4)
+13 NEW DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT
+14 SET DGMTI=IEN4
SET DGMTP=$GET(^DGMT(408.31,DGMTI,0))
+15 SET DA=DGMTI
SET DIK="^DGMT(408.31,"
DO ^DIK
+16 SET DGMTACT="DEL"
DO AFTER^DGMTEVT
SET DGMTINF=0
+17 SET DGMTYPT=4
DO EN^DGMTAUD
End DoDot:1
+18 IF DGMTYPT=4
Begin DoDot:1
+19 ;Check to see if test type 3 is linked with type 4
+20 ;if linked, remove pointer value from test type 3
+21 ; Added FOR loop for LTC Phase III to support multiple type 3 tests
+22 SET GIEN=""
FOR
SET GIEN=$ORDER(^DGMT(408.31,"AT",DGMTI,GIEN))
if GIEN=""
QUIT
Begin DoDot:2
+23 SET DA=GIEN
SET DR="2.08///@"
SET DIE="^DGMT(408.31,"
DO ^DIE
End DoDot:2
End DoDot:1
+24 QUIT
