DGENRDUA ;ALB/TDM - ENROLLMENT RATED DISABILITY UPLOAD AUDIT file (#390) APIs ; 11/14/07 3:11pm
;;5.3;REGISTRATION;**763**;Aug 13,1993;Build 9
;
Q
;
RDCHG(DFN,FDT,TDT) ; API to return Rated Disability changes for Veterans
;****************************************************************
; NOTE: It is the responsibility of the calling application to
; kill the ^TMP($J,"RDCHG") global reference prior to
; calling this api and also after the calling routine is
; done with the global reference.
;****************************************************************
; Input
; DFN - Patients DFN (Optional, If not passed return all vets)
; FDT - Beginning Date Range (Optional)
; TDT - Ending Date Range (Optional)
;
; Output
; DFN = Pointer to PATIENT file (#2)
; OCC = Single occurrence of a Rated Disability change for Veteran
;
; ^TMP($J,"RDCHG",DFN,OCC)=P1^P2^P3^...etc
; Where: P1 = DATE/TIME OF CHANGE (fileman format)
; P2 = RATED DISABILITIES CODE (external value)
; P3 = RATED DISABILITIES NAME (external value)
; P4 = DISABILITY % (numeric value)
; P5 = EXTREMITY AFFECTED (internal code)
; P6 = EXTREMITY AFFECTED (external code)
; P7 = ORIGINAL EFFECTIVE DATE (fileman format)
; P8 = CURRENT EFFECTIVE DATE (fileman format)
;
N XDT,IEN
K ^TMP($J,"RDCHG")
S DFN=$G(DFN),IEN=""
S:$G(FDT)="" FDT=$$FMADD^XLFDT(DT,-365)
S:$G(TDT)="" TDT=DT
S XDT=$$FMADD^XLFDT(FDT,-1),XDT=XDT_".999999"
S TDT=$$FMADD^XLFDT(TDT,1),TDT=TDT_".000001"
I DFN D Q
.F S XDT=$O(^DGRDUA(390,"APTDATE",DFN,XDT)) Q:((XDT<1)!(XDT>TDT)) D
..F S IEN=$O(^DGRDUA(390,"APTDATE",DFN,XDT,IEN)) Q:IEN="" D
...D BLDTMP(IEN)
I 'DFN D Q
.F S XDT=$O(^DGRDUA(390,"ADATEPT",XDT)) Q:((XDT<1)!(XDT>TDT)) D
..F S DFN=$O(^DGRDUA(390,"ADATEPT",XDT,DFN)) Q:DFN="" D
...F S IEN=$O(^DGRDUA(390,"ADATEPT",XDT,DFN,IEN)) Q:IEN="" D
....D BLDTMP(IEN)
Q
;
BLDTMP(IEN) ; Build ^TMP global containing data for calling routine.
Q:$G(IEN)=""
N RDFN,OCC,DISCOD,RETURN,RETARY
D GETS^DIQ(390,IEN,"*","IE","RETARY")
S RDFN=$G(RETARY(390,IEN_",",2,"I")) Q:RDFN=""
S OCC=$O(^TMP($J,"RDCHG",RDFN,""),-1)+1
S DISCOD=$G(RETARY(390,IEN_",",3,"I"))_","
S RETURN=$G(RETARY(390,IEN_",",.01,"I"))
S $P(RETURN,U,2)=$$GET1^DIQ(31,DISCOD,.001)
S $P(RETURN,U,3)=$$GET1^DIQ(31,DISCOD,.01)
S $P(RETURN,U,4)=$G(RETARY(390,IEN_",",4,"E"))
S $P(RETURN,U,5)=$G(RETARY(390,IEN_",",5,"I"))
S $P(RETURN,U,6)=$G(RETARY(390,IEN_",",5,"E"))
S $P(RETURN,U,7)=$G(RETARY(390,IEN_",",6,"I"))
S $P(RETURN,U,8)=$G(RETARY(390,IEN_",",7,"I"))
S ^TMP($J,"RDCHG",RDFN,OCC)=RETURN
Q
;
PURGE ; Purge entries in file #390 that are over 365 days old.
N PDT,DA,EDT,DIK
S (PDT,DA)=0,EDT=$$FMADD^XLFDT(DT,-366)_".999999",DIK="^DGRDUA(390,"
F S PDT=$O(^DGRDUA(390,"B",PDT)) Q:((PDT="")!(PDT>EDT)) D
.F S DA=$O(^DGRDUA(390,"B",PDT,DA)) Q:DA="" D
..D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENRDUA 3068 printed Apr 09, 2024@21:49:34 Page 2
DGENRDUA ;ALB/TDM - ENROLLMENT RATED DISABILITY UPLOAD AUDIT file (#390) APIs ; 11/14/07 3:11pm
+1 ;;5.3;REGISTRATION;**763**;Aug 13,1993;Build 9
+2 ;
+3 QUIT
+4 ;
RDCHG(DFN,FDT,TDT) ; API to return Rated Disability changes for Veterans
+1 ;****************************************************************
+2 ; NOTE: It is the responsibility of the calling application to
+3 ; kill the ^TMP($J,"RDCHG") global reference prior to
+4 ; calling this api and also after the calling routine is
+5 ; done with the global reference.
+6 ;****************************************************************
+7 ; Input
+8 ; DFN - Patients DFN (Optional, If not passed return all vets)
+9 ; FDT - Beginning Date Range (Optional)
+10 ; TDT - Ending Date Range (Optional)
+11 ;
+12 ; Output
+13 ; DFN = Pointer to PATIENT file (#2)
+14 ; OCC = Single occurrence of a Rated Disability change for Veteran
+15 ;
+16 ; ^TMP($J,"RDCHG",DFN,OCC)=P1^P2^P3^...etc
+17 ; Where: P1 = DATE/TIME OF CHANGE (fileman format)
+18 ; P2 = RATED DISABILITIES CODE (external value)
+19 ; P3 = RATED DISABILITIES NAME (external value)
+20 ; P4 = DISABILITY % (numeric value)
+21 ; P5 = EXTREMITY AFFECTED (internal code)
+22 ; P6 = EXTREMITY AFFECTED (external code)
+23 ; P7 = ORIGINAL EFFECTIVE DATE (fileman format)
+24 ; P8 = CURRENT EFFECTIVE DATE (fileman format)
+25 ;
+26 NEW XDT,IEN
+27 KILL ^TMP($JOB,"RDCHG")
+28 SET DFN=$GET(DFN)
SET IEN=""
+29 if $GET(FDT)=""
SET FDT=$$FMADD^XLFDT(DT,-365)
+30 if $GET(TDT)=""
SET TDT=DT
+31 SET XDT=$$FMADD^XLFDT(FDT,-1)
SET XDT=XDT_".999999"
+32 SET TDT=$$FMADD^XLFDT(TDT,1)
SET TDT=TDT_".000001"
+33 IF DFN
Begin DoDot:1
+34 FOR
SET XDT=$ORDER(^DGRDUA(390,"APTDATE",DFN,XDT))
if ((XDT<1)!(XDT>TDT))
QUIT
Begin DoDot:2
+35 FOR
SET IEN=$ORDER(^DGRDUA(390,"APTDATE",DFN,XDT,IEN))
if IEN=""
QUIT
Begin DoDot:3
+36 DO BLDTMP(IEN)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+37 IF 'DFN
Begin DoDot:1
+38 FOR
SET XDT=$ORDER(^DGRDUA(390,"ADATEPT",XDT))
if ((XDT<1)!(XDT>TDT))
QUIT
Begin DoDot:2
+39 FOR
SET DFN=$ORDER(^DGRDUA(390,"ADATEPT",XDT,DFN))
if DFN=""
QUIT
Begin DoDot:3
+40 FOR
SET IEN=$ORDER(^DGRDUA(390,"ADATEPT",XDT,DFN,IEN))
if IEN=""
QUIT
Begin DoDot:4
+41 DO BLDTMP(IEN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+42 QUIT
+43 ;
BLDTMP(IEN) ; Build ^TMP global containing data for calling routine.
+1 if $GET(IEN)=""
QUIT
+2 NEW RDFN,OCC,DISCOD,RETURN,RETARY
+3 DO GETS^DIQ(390,IEN,"*","IE","RETARY")
+4 SET RDFN=$GET(RETARY(390,IEN_",",2,"I"))
if RDFN=""
QUIT
+5 SET OCC=$ORDER(^TMP($JOB,"RDCHG",RDFN,""),-1)+1
+6 SET DISCOD=$GET(RETARY(390,IEN_",",3,"I"))_","
+7 SET RETURN=$GET(RETARY(390,IEN_",",.01,"I"))
+8 SET $PIECE(RETURN,U,2)=$$GET1^DIQ(31,DISCOD,.001)
+9 SET $PIECE(RETURN,U,3)=$$GET1^DIQ(31,DISCOD,.01)
+10 SET $PIECE(RETURN,U,4)=$GET(RETARY(390,IEN_",",4,"E"))
+11 SET $PIECE(RETURN,U,5)=$GET(RETARY(390,IEN_",",5,"I"))
+12 SET $PIECE(RETURN,U,6)=$GET(RETARY(390,IEN_",",5,"E"))
+13 SET $PIECE(RETURN,U,7)=$GET(RETARY(390,IEN_",",6,"I"))
+14 SET $PIECE(RETURN,U,8)=$GET(RETARY(390,IEN_",",7,"I"))
+15 SET ^TMP($JOB,"RDCHG",RDFN,OCC)=RETURN
+16 QUIT
+17 ;
PURGE ; Purge entries in file #390 that are over 365 days old.
+1 NEW PDT,DA,EDT,DIK
+2 SET (PDT,DA)=0
SET EDT=$$FMADD^XLFDT(DT,-366)_".999999"
SET DIK="^DGRDUA(390,"
+3 FOR
SET PDT=$ORDER(^DGRDUA(390,"B",PDT))
if ((PDT="")!(PDT>EDT))
QUIT
Begin DoDot:1
+4 FOR
SET DA=$ORDER(^DGRDUA(390,"B",PDT,DA))
if DA=""
QUIT
Begin DoDot:2
+5 DO ^DIK
End DoDot:2
End DoDot:1
+6 QUIT
