- VAFCADT3 ;ALB/RJS - GOES THROUGH APCA & ATS CROSS-REFERENCE - 5/16/95
- ;;5.3;Registration;**91**;Jun 06, 1996
- BLDHIST(DFN,ADMSSN,ARRAY) ;
- ;
- ;This Routine builds a history of an ADMISSION (ADMSSN)
- ;for a Patient with a certain (DFN)
- ;
- ;The APCA cross-reference catches all Admit Discharge Transfer
- ;(ADT) events
- ;
- ;The ATS cross-reference catches all Specialty Transfers
- ;
- ;The History is returned in the array specified in the array
- ;variable, which can be global or local, e.g. "ZIMBA" OR "^TMP($J)"
- ;if ARRAY is "" or not-defined it is returned in local variable
- ;VAFCADT3
- ;
- ;
- Q:$G(DFN)=""!($G(ADMSSN)="")
- N VADATE,IEN,SPEC,TT,ACTDATE
- I $G(ARRAY)="" S ARRAY="VAFCADT3"
- ;
- ;--$O Through "apca" cross reference of patient movement file
- ; looking for admission, discharge, and transfer events
- ;
- S VADATE=""
- F S VADATE=$O(^DGPM("APCA",DFN,ADMSSN,VADATE)) Q:VADATE="" D
- . S IEN=""
- . F S IEN=$O(^DGPM("APCA",DFN,ADMSSN,VADATE,IEN)) Q:IEN="" D
- . . S TT=$P($G(^DGPM(IEN,0)),"^",2),ACTDATE=$P($G(^DGPM(IEN,0)),"^",1)
- . . I TT'=""&("123"[TT) D
- . . . S @ARRAY@(ACTDATE,IEN)=$S(TT=1:"ADMISSION",TT=2:"TRANSFER",TT=3:"DISCHARGE")
- . . . I $$ASSOCTD(DFN,ADMSSN,$$CONVERT(ACTDATE)) S @ARRAY@(ACTDATE,IEN)=@ARRAY@(ACTDATE,IEN)_",SPECIALTY"
- ;
- ;--$O Through "ats" cross reference of patient movement file
- ; looking for specialty transfer events
- ;
- S VADATE=""
- F S VADATE=$O(^DGPM("ATS",DFN,ADMSSN,VADATE)) Q:VADATE="" D
- . S SPEC=""
- . F S SPEC=$O(^DGPM("ATS",DFN,ADMSSN,VADATE,SPEC)) Q:SPEC="" D
- . . S IEN=""
- . . F S IEN=$O(^DGPM("ATS",DFN,ADMSSN,VADATE,SPEC,IEN)) Q:IEN="" D
- . . . S ACTDATE=$P($G(^DGPM(IEN,0)),"^",1),TT=$P($G(^DGPM(IEN,0)),"^",2)
- . . . I TT'=""&("6"[TT) D
- . . . . I '$D(@ARRAY@(ACTDATE)) S @ARRAY@(ACTDATE,IEN)="SPECIALTY"
- ;
- ;--$O through array created, looking to flag the last movement as
- ; "LASTONE"
- ;
- Q:'$D(@ARRAY)
- S VADATE="",VADATE=$O(@ARRAY@(VADATE),-1)
- S IEN="",IEN=$O(@ARRAY@(VADATE,IEN),-1)
- S @ARRAY@(VADATE,IEN)=@ARRAY@(VADATE,IEN)_",LASTONE"
- Q
- ;
- CONVERT(VADATE) ;
- Q:$G(VADATE)="" -1
- S VADATE=9999999.9999999-VADATE
- Q VADATE
- ASSOCTD(DFN,ADMSSN,VADATE,IEN) ;
- N RESULT
- Q:$D(^DGPM("ATS",DFN,ADMSSN,VADATE)) 1
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCADT3 2257 printed Jan 18, 2025@04:02:10 Page 2
- VAFCADT3 ;ALB/RJS - GOES THROUGH APCA & ATS CROSS-REFERENCE - 5/16/95
- +1 ;;5.3;Registration;**91**;Jun 06, 1996
- BLDHIST(DFN,ADMSSN,ARRAY) ;
- +1 ;
- +2 ;This Routine builds a history of an ADMISSION (ADMSSN)
- +3 ;for a Patient with a certain (DFN)
- +4 ;
- +5 ;The APCA cross-reference catches all Admit Discharge Transfer
- +6 ;(ADT) events
- +7 ;
- +8 ;The ATS cross-reference catches all Specialty Transfers
- +9 ;
- +10 ;The History is returned in the array specified in the array
- +11 ;variable, which can be global or local, e.g. "ZIMBA" OR "^TMP($J)"
- +12 ;if ARRAY is "" or not-defined it is returned in local variable
- +13 ;VAFCADT3
- +14 ;
- +15 ;
- +16 if $GET(DFN)=""!($GET(ADMSSN)="")
- QUIT
- +17 NEW VADATE,IEN,SPEC,TT,ACTDATE
- +18 IF $GET(ARRAY)=""
- SET ARRAY="VAFCADT3"
- +19 ;
- +20 ;--$O Through "apca" cross reference of patient movement file
- +21 ; looking for admission, discharge, and transfer events
- +22 ;
- +23 SET VADATE=""
- +24 FOR
- SET VADATE=$ORDER(^DGPM("APCA",DFN,ADMSSN,VADATE))
- if VADATE=""
- QUIT
- Begin DoDot:1
- +25 SET IEN=""
- +26 FOR
- SET IEN=$ORDER(^DGPM("APCA",DFN,ADMSSN,VADATE,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +27 SET TT=$PIECE($GET(^DGPM(IEN,0)),"^",2)
- SET ACTDATE=$PIECE($GET(^DGPM(IEN,0)),"^",1)
- +28 IF TT'=""&("123"[TT)
- Begin DoDot:3
- +29 SET @ARRAY@(ACTDATE,IEN)=$SELECT(TT=1:"ADMISSION",TT=2:"TRANSFER",TT=3:"DISCHARGE")
- +30 IF $$ASSOCTD(DFN,ADMSSN,$$CONVERT(ACTDATE))
- SET @ARRAY@(ACTDATE,IEN)=@ARRAY@(ACTDATE,IEN)_",SPECIALTY"
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +31 ;
- +32 ;--$O Through "ats" cross reference of patient movement file
- +33 ; looking for specialty transfer events
- +34 ;
- +35 SET VADATE=""
- +36 FOR
- SET VADATE=$ORDER(^DGPM("ATS",DFN,ADMSSN,VADATE))
- if VADATE=""
- QUIT
- Begin DoDot:1
- +37 SET SPEC=""
- +38 FOR
- SET SPEC=$ORDER(^DGPM("ATS",DFN,ADMSSN,VADATE,SPEC))
- if SPEC=""
- QUIT
- Begin DoDot:2
- +39 SET IEN=""
- +40 FOR
- SET IEN=$ORDER(^DGPM("ATS",DFN,ADMSSN,VADATE,SPEC,IEN))
- if IEN=""
- QUIT
- Begin DoDot:3
- +41 SET ACTDATE=$PIECE($GET(^DGPM(IEN,0)),"^",1)
- SET TT=$PIECE($GET(^DGPM(IEN,0)),"^",2)
- +42 IF TT'=""&("6"[TT)
- Begin DoDot:4
- +43 IF '$DATA(@ARRAY@(ACTDATE))
- SET @ARRAY@(ACTDATE,IEN)="SPECIALTY"
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +44 ;
- +45 ;--$O through array created, looking to flag the last movement as
- +46 ; "LASTONE"
- +47 ;
- +48 if '$DATA(@ARRAY)
- QUIT
- +49 SET VADATE=""
- SET VADATE=$ORDER(@ARRAY@(VADATE),-1)
- +50 SET IEN=""
- SET IEN=$ORDER(@ARRAY@(VADATE,IEN),-1)
- +51 SET @ARRAY@(VADATE,IEN)=@ARRAY@(VADATE,IEN)_",LASTONE"
- +52 QUIT
- +53 ;
- CONVERT(VADATE) ;
- +1 if $GET(VADATE)=""
- QUIT -1
- +2 SET VADATE=9999999.9999999-VADATE
- +3 QUIT VADATE
- ASSOCTD(DFN,ADMSSN,VADATE,IEN) ;
- +1 NEW RESULT
- +2 if $DATA(^DGPM("ATS",DFN,ADMSSN,VADATE))
- QUIT 1
- +3 QUIT 0