- 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 Feb 19, 2025@00:09:01 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