AQALDG5 ; IHS/ORDC/LJF - AUTOLINK ADT OCCURRENCES ;
;;1;QI LINKAGES-RPMS;;AUG 15, 1994
;
;Called by OR/EE Event Driver via MAS option DGPM MOVEMENT EVENTS
;Required input: DFN=patient internal #
; DGPMA=after node for movement
; DUZ(2)=admission facility
; DGPMT=type of movement
;
Q:'$D(DFN) Q:'$D(DGPMDA) Q:DGPMDA=""
Q:'$D(DUZ(2)) Q:'$D(DGPMA) Q:'$D(DGPMT)
;
Q:DGPMT>3 ;not adm,wd transf,disch
S DGPMCA=$P(DGPMA,U,14) I DGPMA="" S DGPMCA=$P(DGPMP,U,14)
I DGPMP="" D @DGPMT,^AQALKILL Q ;new event, not an edit
S AQALVST=$P($G(^DGPM(+DGPMCA,"IHS")),U) I AQALVST="" K AQALVST Q
I '$D(^AQAOC("AE",DFN,AQALVST)),+DGPMA D @DGPMT,^AQALKILL Q ;no occ
D ^AQALDG53,^AQALKILL Q ;mod or delete occ already set
;
1 ; >> admission events
; find admit type & srv; check if transfer in
K ^UTILITY("DIQ1",$J)
S (AQALF,DIC)=405.1,DA=$P(DGPMA,U,4),DR="9999999.1"
D EN^DIQ1 S AQALX=^UTILITY("DIQ1",$J,AQALF,DA,9999999.1)
;
I (AQALX=2)!(AQALX=3) D
.S AQALEV=1001,AQALSVI=2,AQALSV=$$SRV(DGPMCA) Q:'$$LINK
.D TI^AQALDG50,^AQALDG51 ;get xtra data & create occ
;
; find last disch & current admit dates for readmission
S AQALCUR=+DGPMA,AQALIVDT=$$IDATE(AQALCUR)
S AQALST=$O(^DGPM("ATID3",DFN,AQALIVDT))
I +AQALCUR,+AQALST D ;at least one prev admission
.S AQALEV=1011,AQALSVI=3,AQALSV=$$SRV(DGPMCA) Q:'$$LINK
.D READM^AQALDG50,^AQALDG51 ;get xtra data & create occ
;
; find last day surgery
S AQALST=$O(^ADGDS("APID",DFN,AQALIVDT))
I +AQALCUR,+AQALST D ;at least one d s
.S AQALEV=1021,AQALSVI=4,AQALSV=$$SRV(DGPMCA) Q:'$$LINK
.D DSADM^AQALDG50,^AQALDG51 ;get xtra data & create occ
;
Q
;
2 ; >> ward transfer events
; check for icu transfer
S X=$P(DGPMA,U,6) Q:'$$ICU(X)
S AQALST=$$IDATE(+DGPMA)
F S AQALST=$O(^DGPM("APMV",DFN,DGPMCA,AQALST)) Q:AQALST="" Q:$$TYP=2
S AQALEV=1031,AQALSVI=5,AQALSV=$$SRV(DGPMDA)
S:AQALST="" AQALST=$$IDATE(+^DGPM(DGPMCA,0))
I $$LINK D ICU^AQALDG50,^AQALDG51 ;get xtra data & create occ
;
; check for return to icu
S AQALST=$$IDATE(+DGPMA)
F S AQALST=$O(^DGPM("APMV",DFN,DGPMCA,AQALST)) Q:AQALST="" Q:$$ICU1
I AQALST]"" S AQALST=$O(^DGPM("APTT2",DFN,$$IDATE(AQALST)))
I +DGPMA,+AQALST D
.S AQALEV=1071,AQALSVI=9,AQALSV=$$SRV(DGPMDA) Q:'$$LINK
.D RICU^AQALDG50,^AQALDG51 ;get xtra data & create occ
;
Q
;
3 ;>> discharge events
;find discharge type
K ^UTILITY("DIQ1",$J)
S (AQALF,DIC)=405.1,DA=$P(DGPMA,U,4),DR="9999999.1"
D EN^DIQ1 S AQALX=^UTILITY("DIQ1",$J,AQALF,DA,9999999.1)
;
;determine discharge link:1051=transfer,1041=ama,1061=death
S AQALEV=$S(AQALX=2:1051,AQALX=3:1041,AQALX<2:"",AQALX>7:"",1:1061)
Q:AQALEV=""
S AQALSVI=$S(AQALX=2:7,AQALX=3:6,AQALX<1:"",AQALX>7:"",1:8)
S AQALSV=$$DSRV,AQALWD=$$DWD
Q:'$$LINK
D DSCH^AQALDG50,^AQALDG51 ;get data items & create occ
;
Q
;
LINK() ; >> find if link turned on
N DIC,DR,DA,AQALON S AQALON=0
G LINKEND:'$D(^AQAGP(DUZ(2))) ;no params for site
K ^UTILITY("DIQ1",$J) S AQALF=9002166.4,DIC="^AQAGP(",DA=DUZ(2)
S DR="" F I=0:1:3 S DR=DR_(AQALEV+I)_";"
D EN^DIQ1
G LINKEND:^UTILITY("DIQ1",$J,AQALF,DUZ(2),AQALEV)'="ON" ;turned on?
G LINKEND:^UTILITY("DIQ1",$J,AQALF,DUZ(2),AQALEV+1)="" ;chk ind 4 link
G LINKEND:AQALSV="" S AQALX=0 ;link on for this srv?
F S AQALX=$O(^AQAGP(DUZ(2),"SRV","B",AQALSV,AQALX)) Q:AQALX="" D
.Q:'+$P($G(^AQAGP(DUZ(2),"SRV",AQALX,0)),U,AQALSVI)
.Q:'$$TIME ;check time limit
.S AQALON=1
LINKEND Q AQALON
;
TIME() ; >> check time limit against dates
N AQALYES,AQALNUM S AQALYES=1
I (AQALEV=1011)!(AQALEV=1021)!(AQALEV=1071) D
.S AQALNUM=$P($G(^AQAGP(DUZ(2),"SRV",AQALX,1)),U,AQALSVI) Q:AQALNUM=""
.S X1=+DGPMA,X2=$$IDATE(AQALST) Q:X2=0 D ^%DTC
.I X>AQALNUM S AQALYES=0
Q $G(AQALYES)
;
SRV(X) ; >> hospital srv ifn for movement
N Y
S Y=$O(^DGPM("APHY",X,0))
I Y="" S Y=$$LSRV
I Y]"" S Y=$P(^DGPM(Y,0),U,9)
I Y]"" S Y=$P($G(^DIC(45.7,Y,0)),U,4)
Q Y
;
LSRV() ; >> find last time srv was transferred
N X,Y S Y=$$IDATE(+DGPMA)
S X=$O(^DGPM("ATID6",DFN,+$O(^DGPM("ATID6",DFN,Y)),0))
I X="" S X=DGPMCA
Q X
;
ICU(X) ; >> see if ward is an ICU
Q $S($P($G(^DIC(42,X,"IHS")),U)="Y":1,1:0)
;
ICU1() ; >> was last ward ICU?
N X,Y I $$TYP'=2 Q 0
S X=$O(^DGPM("APMV",DFN,DGPMCA,AQALST,0))
I X S X=$P($G(^DGPM(X,0)),U,6)
I X S Y=$$ICU(X)
Q $G(Y)
;
TYP() ; >> find type of movemnt for last movemnt
N X,Y
S X=$O(^DGPM("APMV",DFN,DGPMCA,AQALST,0))
I X S Y=$P($G(^DGPM(X,0)),U,2)
Q $G(Y)
;
DSRV() ; >> find disch srv
N X,Y S Y=9999999.9999999-$G(^DGPM(+$P(^DGPM(DGPMCA,0),U,17),0))
S X=$O(^DGPM("ATID6",DFN,$O(^DGPM("ATID6",DFN,Y)),0))
I X="" S X=DGPMCA
Q $P($G(^DIC(45.7,$P($G(^DGPM(+X,0)),U,9),0)),U,4)
;
DWD() ; >> find disch ward
N X,Y,Z S Y=$G(^DGPM(+$P(^DGPM(DGPMCA,0),U,17),0)),Y=$$IDATE(+Y)
S X=$O(^DGPM("ATID2",DFN,Y))
I X>$$IDATE(+^DGPM(DGPMCA,0)) S Z=DGPMCA
I X]"",'$D(Z) S Z=$O(^DGPM("ATID2",DFN,X,0))
I X="" S Z=DGPMCA
Q $P($G(^DGPM(+Z,0)),U,6)
;
IDATE(X) ; >> inverse date
Q (9999999.9999999-X)
AQALDG5 ; IHS/ORDC/LJF - AUTOLINK ADT OCCURRENCES ;
+1 ;;1;QI LINKAGES-RPMS;;AUG 15, 1994
+2 ;
+3 ;Called by OR/EE Event Driver via MAS option DGPM MOVEMENT EVENTS
+4 ;Required input: DFN=patient internal #
+5 ; DGPMA=after node for movement
+6 ; DUZ(2)=admission facility
+7 ; DGPMT=type of movement
+8 ;
+9 IF '$DATA(DFN)
QUIT
IF '$DATA(DGPMDA)
QUIT
IF DGPMDA=""
QUIT
+10 IF '$DATA(DUZ(2))
QUIT
IF '$DATA(DGPMA)
QUIT
IF '$DATA(DGPMT)
QUIT
+11 ;
+12 ;not adm,wd transf,disch
IF DGPMT>3
QUIT
+13 SET DGPMCA=$PIECE(DGPMA,U,14)
IF DGPMA=""
SET DGPMCA=$PIECE(DGPMP,U,14)
+14 ;new event, not an edit
IF DGPMP=""
DO @DGPMT
DO ^AQALKILL
QUIT
+15 SET AQALVST=$PIECE($GET(^DGPM(+DGPMCA,"IHS")),U)
IF AQALVST=""
KILL AQALVST
QUIT
+16 ;no occ
IF '$DATA(^AQAOC("AE",DFN,AQALVST))
IF +DGPMA
DO @DGPMT
DO ^AQALKILL
QUIT
+17 ;mod or delete occ already set
DO ^AQALDG53
DO ^AQALKILL
QUIT
+18 ;
1 ; >> admission events
+1 ; find admit type & srv; check if transfer in
+2 KILL ^UTILITY("DIQ1",$JOB)
+3 SET (AQALF,DIC)=405.1
SET DA=$PIECE(DGPMA,U,4)
SET DR="9999999.1"
+4 DO EN^DIQ1
SET AQALX=^UTILITY("DIQ1",$JOB,AQALF,DA,9999999.1)
+5 ;
+6 IF (AQALX=2)!(AQALX=3)
Begin DoDot:1
+7 SET AQALEV=1001
SET AQALSVI=2
SET AQALSV=$$SRV(DGPMCA)
IF '$$LINK
QUIT
+8 ;get xtra data & create occ
DO TI^AQALDG50
DO ^AQALDG51
End DoDot:1
+9 ;
+10 ; find last disch & current admit dates for readmission
+11 SET AQALCUR=+DGPMA
SET AQALIVDT=$$IDATE(AQALCUR)
+12 SET AQALST=$ORDER(^DGPM("ATID3",DFN,AQALIVDT))
+13 ;at least one prev admission
IF +AQALCUR
IF +AQALST
Begin DoDot:1
+14 SET AQALEV=1011
SET AQALSVI=3
SET AQALSV=$$SRV(DGPMCA)
IF '$$LINK
QUIT
+15 ;get xtra data & create occ
DO READM^AQALDG50
DO ^AQALDG51
End DoDot:1
+16 ;
+17 ; find last day surgery
+18 SET AQALST=$ORDER(^ADGDS("APID",DFN,AQALIVDT))
+19 ;at least one d s
IF +AQALCUR
IF +AQALST
Begin DoDot:1
+20 SET AQALEV=1021
SET AQALSVI=4
SET AQALSV=$$SRV(DGPMCA)
IF '$$LINK
QUIT
+21 ;get xtra data & create occ
DO DSADM^AQALDG50
DO ^AQALDG51
End DoDot:1
+22 ;
+23 QUIT
+24 ;
2 ; >> ward transfer events
+1 ; check for icu transfer
+2 SET X=$PIECE(DGPMA,U,6)
IF '$$ICU(X)
QUIT
+3 SET AQALST=$$IDATE(+DGPMA)
+4 FOR
SET AQALST=$ORDER(^DGPM("APMV",DFN,DGPMCA,AQALST))
IF AQALST=""
QUIT
IF $$TYP=2
QUIT
+5 SET AQALEV=1031
SET AQALSVI=5
SET AQALSV=$$SRV(DGPMDA)
+6 IF AQALST=""
SET AQALST=$$IDATE(+^DGPM(DGPMCA,0))
+7 ;get xtra data & create occ
IF $$LINK
DO ICU^AQALDG50
DO ^AQALDG51
+8 ;
+9 ; check for return to icu
+10 SET AQALST=$$IDATE(+DGPMA)
+11 FOR
SET AQALST=$ORDER(^DGPM("APMV",DFN,DGPMCA,AQALST))
IF AQALST=""
QUIT
IF $$ICU1
QUIT
+12 IF AQALST]""
SET AQALST=$ORDER(^DGPM("APTT2",DFN,$$IDATE(AQALST)))
+13 IF +DGPMA
IF +AQALST
Begin DoDot:1
+14 SET AQALEV=1071
SET AQALSVI=9
SET AQALSV=$$SRV(DGPMDA)
IF '$$LINK
QUIT
+15 ;get xtra data & create occ
DO RICU^AQALDG50
DO ^AQALDG51
End DoDot:1
+16 ;
+17 QUIT
+18 ;
3 ;>> discharge events
+1 ;find discharge type
+2 KILL ^UTILITY("DIQ1",$JOB)
+3 SET (AQALF,DIC)=405.1
SET DA=$PIECE(DGPMA,U,4)
SET DR="9999999.1"
+4 DO EN^DIQ1
SET AQALX=^UTILITY("DIQ1",$JOB,AQALF,DA,9999999.1)
+5 ;
+6 ;determine discharge link:1051=transfer,1041=ama,1061=death
+7 SET AQALEV=$SELECT(AQALX=2:1051,AQALX=3:1041,AQALX<2:"",AQALX>7:"",1:1061)
+8 IF AQALEV=""
QUIT
+9 SET AQALSVI=$SELECT(AQALX=2:7,AQALX=3:6,AQALX<1:"",AQALX>7:"",1:8)
+10 SET AQALSV=$$DSRV
SET AQALWD=$$DWD
+11 IF '$$LINK
QUIT
+12 ;get data items & create occ
DO DSCH^AQALDG50
DO ^AQALDG51
+13 ;
+14 QUIT
+15 ;
LINK() ; >> find if link turned on
+1 NEW DIC,DR,DA,AQALON
SET AQALON=0
+2 ;no params for site
IF '$DATA(^AQAGP(DUZ(2)))
GOTO LINKEND
+3 KILL ^UTILITY("DIQ1",$JOB)
SET AQALF=9002166.4
SET DIC="^AQAGP("
SET DA=DUZ(2)
+4 SET DR=""
FOR I=0:1:3
SET DR=DR_(AQALEV+I)_";"
+5 DO EN^DIQ1
+6 ;turned on?
IF ^UTILITY("DIQ1",$JOB,AQALF,DUZ(2),AQALEV)'="ON"
GOTO LINKEND
+7 ;chk ind 4 link
IF ^UTILITY("DIQ1",$JOB,AQALF,DUZ(2),AQALEV+1)=""
GOTO LINKEND
+8 ;link on for this srv?
IF AQALSV=""
GOTO LINKEND
SET AQALX=0
+9 FOR
SET AQALX=$ORDER(^AQAGP(DUZ(2),"SRV","B",AQALSV,AQALX))
IF AQALX=""
QUIT
Begin DoDot:1
+10 IF '+$PIECE($GET(^AQAGP(DUZ(2),"SRV",AQALX,0)),U,AQALSVI)
QUIT
+11 ;check time limit
IF '$$TIME
QUIT
+12 SET AQALON=1
End DoDot:1
LINKEND QUIT AQALON
+1 ;
TIME() ; >> check time limit against dates
+1 NEW AQALYES,AQALNUM
SET AQALYES=1
+2 IF (AQALEV=1011)!(AQALEV=1021)!(AQALEV=1071)
Begin DoDot:1
+3 SET AQALNUM=$PIECE($GET(^AQAGP(DUZ(2),"SRV",AQALX,1)),U,AQALSVI)
IF AQALNUM=""
QUIT
+4 SET X1=+DGPMA
SET X2=$$IDATE(AQALST)
IF X2=0
QUIT
DO ^%DTC
+5 IF X>AQALNUM
SET AQALYES=0
End DoDot:1
+6 QUIT $GET(AQALYES)
+7 ;
SRV(X) ; >> hospital srv ifn for movement
+1 NEW Y
+2 SET Y=$ORDER(^DGPM("APHY",X,0))
+3 IF Y=""
SET Y=$$LSRV
+4 IF Y]""
SET Y=$PIECE(^DGPM(Y,0),U,9)
+5 IF Y]""
SET Y=$PIECE($GET(^DIC(45.7,Y,0)),U,4)
+6 QUIT Y
+7 ;
LSRV() ; >> find last time srv was transferred
+1 NEW X,Y
SET Y=$$IDATE(+DGPMA)
+2 SET X=$ORDER(^DGPM("ATID6",DFN,+$ORDER(^DGPM("ATID6",DFN,Y)),0))
+3 IF X=""
SET X=DGPMCA
+4 QUIT X
+5 ;
ICU(X) ; >> see if ward is an ICU
+1 QUIT $SELECT($PIECE($GET(^DIC(42,X,"IHS")),U)="Y":1,1:0)
+2 ;
ICU1() ; >> was last ward ICU?
+1 NEW X,Y
IF $$TYP'=2
QUIT 0
+2 SET X=$ORDER(^DGPM("APMV",DFN,DGPMCA,AQALST,0))
+3 IF X
SET X=$PIECE($GET(^DGPM(X,0)),U,6)
+4 IF X
SET Y=$$ICU(X)
+5 QUIT $GET(Y)
+6 ;
TYP() ; >> find type of movemnt for last movemnt
+1 NEW X,Y
+2 SET X=$ORDER(^DGPM("APMV",DFN,DGPMCA,AQALST,0))
+3 IF X
SET Y=$PIECE($GET(^DGPM(X,0)),U,2)
+4 QUIT $GET(Y)
+5 ;
DSRV() ; >> find disch srv
+1 NEW X,Y
SET Y=9999999.9999999-$GET(^DGPM(+$PIECE(^DGPM(DGPMCA,0),U,17),0))
+2 SET X=$ORDER(^DGPM("ATID6",DFN,$ORDER(^DGPM("ATID6",DFN,Y)),0))
+3 IF X=""
SET X=DGPMCA
+4 QUIT $PIECE($GET(^DIC(45.7,$PIECE($GET(^DGPM(+X,0)),U,9),0)),U,4)
+5 ;
DWD() ; >> find disch ward
+1 NEW X,Y,Z
SET Y=$GET(^DGPM(+$PIECE(^DGPM(DGPMCA,0),U,17),0))
SET Y=$$IDATE(+Y)
+2 SET X=$ORDER(^DGPM("ATID2",DFN,Y))
+3 IF X>$$IDATE(+^DGPM(DGPMCA,0))
SET Z=DGPMCA
+4 IF X]""
IF '$DATA(Z)
SET Z=$ORDER(^DGPM("ATID2",DFN,X,0))
+5 IF X=""
SET Z=DGPMCA
+6 QUIT $PIECE($GET(^DGPM(+Z,0)),U,6)
+7 ;
IDATE(X) ; >> inverse date
+1 QUIT (9999999.9999999-X)
