AQALDG50.m

AQALDG50 ; IHS/ORDC/LJF - AUTOLINK ADT OCC CONT. ;

 ;;1;QI LINKAGES-RPMS;;AUG 15, 1994

 ;

 ;This rtn contains a series of entry points called by ^AQALDG5 to

 ;find event specific information prior to creating occurrences.

 ;

TI ;EP >> get extra data for transfer in

 S Y=$P(DGPMA,U,5),C=$P(^DD(405,.05,0),U,2) D Y^DIQ

 S AQALXTR(1)="Facility transferred from:  "_Y

 Q

 ;

READM ;EP >> get extra data for readmissions

 S AQALX=$O(^DGPM("ATID3",DFN,AQALST,0)),AQALX=$G(^DGPM(AQALX,0))

 S AQALDC=+AQALX,AQALCA=$P(AQALX,U,14)

 S AQALXTR(1)=" Last discharge date:  "_$$FMTE^XLFDT(+AQALDC)

 S AQALXTR(2)=" Last discharge service:  "_$$SRVP($P(AQALX,U,14))

 S AQALXTR(3)=" Last admission dx:  "_$P(^DGPM(AQALCA,0),U,10)

 S AQALXTR(4)=" This admission dx:  "_$P(DGPMA,U,10)

 Q

 ;

DSADM ;EP >> get extra data for admit after day surgery

 S AQALX=$O(^ADGDS("APID",DFN,AQALST,0))

 S AQALX=$G(^ADGDS(DFN,"DS",AQALX,0))

 S AQALXTR(1)=" Last Day Surgery Date:  "_$$FMTE^XLFDT(+AQALX)

 S AQALXTR(2)=" Last Day Surgery service:  "_$$DSSRV(AQALX)

 S AQALXTR(3)=" Last Day Surgery Procedure:  "_$P(AQALX,U,2)

 S AQALXTR(4)=" This admission dx:  "_$P(DGPMA,U,10)

 Q

 ;

ICU ;EP >> get extra data for icu transfers

 S X=$O(^DGPM("APMV",DFN,DGPMCA,AQALST,0)),AQALX=$G(^DGPM(X,0))

 S AQALXTR(1)=" Last ward:  "_$$WDP(AQALX)

 S AQALXTR(2)=" Admission dx:  "_$P($G(^DGPM(DGPMCA,0)),U,10)

 Q

 ;

RICU ;EP >> get extra data for return to icu

 S AQALXTR(1)=" Last discharge from ICU:  "_$$FMTE^XLFDT(AQALST)

 S AQALXTR(2)=" Admission dx:  "_$P($G(^DGPM(DGPMCA,0)),U,10)

 Q

 ;

DSCH ;EP >> get extra data for discharges

 S AQALXTR(1)=" Admission dx:  "_$P($G(^DGPM(DGPMCA,0)),U,10)

 I AQALEV=1051 D

 .S Y=$P(DGPMA,U,5),C=$P(^DD(405,.05,0),U,2) D Y^DIQ

 .S AQALXTR(2)=" Transferred to:  "_Y

 Q

 ;

SRV(X) ; >> hospital service ifn for movement

 N Y S Y=$O(^DGPM("APHY",X,0))

 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

 ;

SRVP(X) ; >> hospital service name

 Q $P($G(^DIC(49,+$$SRV(X),0)),U)

 ;

WDP(X) ; >> ward name

 Q $P($G(^DIC(42,$P(X,U,6),0)),U)

 ;

IVDTP(X) ; >> convert inverse date to readable date

 Q $$FMTE^XLFDT($$IDATE(X))

 ;

IDATE(X) ; >> inverse date

 Q (9999999.9999999-X)

 ;

DSSRV(X) ; >> find day surgery service

 Q $P($G(^DIC(49,$P($G(^DIC(45.7,$P(AQALX,U,5),0)),U,4),0)),U)

AQALDG50  ; IHS/ORDC/LJF - AUTOLINK ADT OCC CONT. ;

 +1       ;;1;QI LINKAGES-RPMS;;AUG 15, 1994

 +2       ;

 +3       ;This rtn contains a series of entry points called by ^AQALDG5 to

 +4       ;find event specific information prior to creating occurrences.

 +5       ;

TI        ;EP >> get extra data for transfer in

 +1        SET Y=$PIECE(DGPMA,U,5)

           SET C=$PIECE(^DD(405,.05,0),U,2)

           DO Y^DIQ

 +2        SET AQALXTR(1)="Facility transferred from:  "_Y

 +3        QUIT 

 +4       ;

READM     ;EP >> get extra data for readmissions

 +1        SET AQALX=$ORDER(^DGPM("ATID3",DFN,AQALST,0))

           SET AQALX=$GET(^DGPM(AQALX,0))

 +2        SET AQALDC=+AQALX

           SET AQALCA=$PIECE(AQALX,U,14)

 +3        SET AQALXTR(1)=" Last discharge date:  "_$$FMTE^XLFDT(+AQALDC)

 +4        SET AQALXTR(2)=" Last discharge service:  "_$$SRVP($PIECE(AQALX,U,14))

 +5        SET AQALXTR(3)=" Last admission dx:  "_$PIECE(^DGPM(AQALCA,0),U,10)

 +6        SET AQALXTR(4)=" This admission dx:  "_$PIECE(DGPMA,U,10)

 +7        QUIT 

 +8       ;

DSADM     ;EP >> get extra data for admit after day surgery

 +1        SET AQALX=$ORDER(^ADGDS("APID",DFN,AQALST,0))

 +2        SET AQALX=$GET(^ADGDS(DFN,"DS",AQALX,0))

 +3        SET AQALXTR(1)=" Last Day Surgery Date:  "_$$FMTE^XLFDT(+AQALX)

 +4        SET AQALXTR(2)=" Last Day Surgery service:  "_$$DSSRV(AQALX)

 +5        SET AQALXTR(3)=" Last Day Surgery Procedure:  "_$PIECE(AQALX,U,2)

 +6        SET AQALXTR(4)=" This admission dx:  "_$PIECE(DGPMA,U,10)

 +7        QUIT 

 +8       ;

ICU       ;EP >> get extra data for icu transfers

 +1        SET X=$ORDER(^DGPM("APMV",DFN,DGPMCA,AQALST,0))

           SET AQALX=$GET(^DGPM(X,0))

 +2        SET AQALXTR(1)=" Last ward:  "_$$WDP(AQALX)

 +3        SET AQALXTR(2)=" Admission dx:  "_$PIECE($GET(^DGPM(DGPMCA,0)),U,10)

 +4        QUIT 

 +5       ;

RICU      ;EP >> get extra data for return to icu

 +1        SET AQALXTR(1)=" Last discharge from ICU:  "_$$FMTE^XLFDT(AQALST)

 +2        SET AQALXTR(2)=" Admission dx:  "_$PIECE($GET(^DGPM(DGPMCA,0)),U,10)

 +3        QUIT 

 +4       ;

DSCH      ;EP >> get extra data for discharges

 +1        SET AQALXTR(1)=" Admission dx:  "_$PIECE($GET(^DGPM(DGPMCA,0)),U,10)

 +2        IF AQALEV=1051

               Begin DoDot:1

 +3                SET Y=$PIECE(DGPMA,U,5)

                   SET C=$PIECE(^DD(405,.05,0),U,2)

                   DO Y^DIQ

 +4                SET AQALXTR(2)=" Transferred to:  "_Y

               End DoDot:1

 +5        QUIT 

 +6       ;

SRV(X)    ; >> hospital service ifn for movement

 +1        NEW Y

           SET Y=$ORDER(^DGPM("APHY",X,0))

 +2        IF Y]""

               SET Y=$PIECE(^DGPM(Y,0),U,9)

 +3        IF Y]""

               SET Y=$PIECE($GET(^DIC(45.7,Y,0)),U,4)

 +4        QUIT Y

 +5       ;

SRVP(X)   ; >> hospital service name

 +1        QUIT $PIECE($GET(^DIC(49,+$$SRV(X),0)),U)

 +2       ;

WDP(X)    ; >> ward name

 +1        QUIT $PIECE($GET(^DIC(42,$PIECE(X,U,6),0)),U)

 +2       ;

IVDTP(X)  ; >> convert inverse date to readable date

 +1        QUIT $$FMTE^XLFDT($$IDATE(X))

 +2       ;

IDATE(X)  ; >> inverse date

 +1        QUIT (9999999.9999999-X)

 +2       ;

DSSRV(X)  ; >> find day surgery service

 +1        QUIT $PIECE($GET(^DIC(49,$PIECE($GET(^DIC(45.7,$PIECE(AQALX,U,5),0)),U,4),0)),U)