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 Oct 16, 2024@19:02:01 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
