QAOC199 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ;5/13/93 09:06
;;3.0;Occurrence Screen;;09/14/1993
;SCREEN 199 -- READMISSION TO ACUTE CARE WITHIN 48 HOURS OF DISCHARGE
; FROM EXTENDED CARE
Q:$$INACTIVE^QAOC0(199)
F QAOSDT=(QAMTODAY-.0000001):0 S QAOSDT=$O(^DGPM("AMV1",QAOSDT)) Q:QAOSDT'>0!(QAOSDT>(QAMTODAY+.24))!(QAOSDT\1'?7N) F QAOSDFN=0:0 S QAOSDFN=$O(^DGPM("AMV1",QAOSDT,QAOSDFN)) Q:QAOSDFN'>0 D
. F QAOSD0=0:0 S QAOSD0=$O(^DGPM("AMV1",QAOSDT,QAOSDFN,QAOSD0)) Q:QAOSD0'>0 D:$D(^DGPM(QAOSD0,0))#2 MAIN
. Q
Q
MAIN ;
D VADPT^QAOC0(QAOSDFN,QAOSD0) S QAOSDIAG=VAIP(9)
Q:$$TXSP^QAOC0("AS",+VAIP(8))'>0
S X1=QAOSDT,X2=-2 D C^%DTC S QAOSDCXX=9999999.9999999-X
S QA=9999999.9999999-QAOSDT,QAOFOUND=0
F QAOSDCDT=QA:0 S QAOSDCDT=$O(^DGPM("ATID3",QAOSDFN,QAOSDCDT)) Q:(QAOSDCDT'>0)!(QAOSDCDT>QAOSDCXX)!(QAOSDCDT\1'?7N)!QAOFOUND F QAOSDCD0=0:0 S QAOSDCD0=$O(^DGPM("ATID3",QAOSDFN,QAOSDCDT,QAOSDCD0)) Q:QAOSDCD0'>0!QAOFOUND D
. Q:"^31^32^34^"'[("^"_$P($G(^DGPM(QAOSDCD0,0)),"^",18)_"^")
. D VADPT^QAOC0(QAOSDFN,QAOSDCD0) S QAOFOUND=1
. S ^UTILITY($J,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""
. S WARDCLIN=+VAIP(5)_"^"
. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=WARDCLIN
. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)
. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=+VAIP(3)
. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=QAOSDIAG
. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=QAOSD0
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOC199 1543 printed Dec 13, 2024@02:21:03 Page 2
QAOC199 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ;5/13/93 09:06
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 ;SCREEN 199 -- READMISSION TO ACUTE CARE WITHIN 48 HOURS OF DISCHARGE
+3 ; FROM EXTENDED CARE
+4 if $$INACTIVE^QAOC0(199)
QUIT
+5 FOR QAOSDT=(QAMTODAY-.0000001):0
SET QAOSDT=$ORDER(^DGPM("AMV1",QAOSDT))
if QAOSDT'>0!(QAOSDT>(QAMTODAY+.24))!(QAOSDT\1'?7N)
QUIT
FOR QAOSDFN=0:0
SET QAOSDFN=$ORDER(^DGPM("AMV1",QAOSDT,QAOSDFN))
if QAOSDFN'>0
QUIT
Begin DoDot:1
+6 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^DGPM("AMV1",QAOSDT,QAOSDFN,QAOSD0))
if QAOSD0'>0
QUIT
if $DATA(^DGPM(QAOSD0,0))#2
DO MAIN
+7 QUIT
End DoDot:1
+8 QUIT
MAIN ;
+1 DO VADPT^QAOC0(QAOSDFN,QAOSD0)
SET QAOSDIAG=VAIP(9)
+2 if $$TXSP^QAOC0("AS",+VAIP(8))'>0
QUIT
+3 SET X1=QAOSDT
SET X2=-2
DO C^%DTC
SET QAOSDCXX=9999999.9999999-X
+4 SET QA=9999999.9999999-QAOSDT
SET QAOFOUND=0
+5 FOR QAOSDCDT=QA:0
SET QAOSDCDT=$ORDER(^DGPM("ATID3",QAOSDFN,QAOSDCDT))
if (QAOSDCDT'>0)!(QAOSDCDT>QAOSDCXX)!(QAOSDCDT\1'?7N)!QAOFOUND
QUIT
FOR QAOSDCD0=0:0
SET QAOSDCD0=$ORDER(^DGPM("ATID3",QAOSDFN,QAOSDCDT,QAOSDCD0))
if QAOSDCD0'>0!QAOFOUND
QUIT
Begin DoDot:1
+6 if "^31^32^34^"'[("^"_$PIECE($GET(^DGPM(QAOSDCD0,0)),"^",18)_"^")
QUIT
+7 DO VADPT^QAOC0(QAOSDFN,QAOSDCD0)
SET QAOFOUND=1
+8 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""
+9 SET WARDCLIN=+VAIP(5)_"^"
+10 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=WARDCLIN
+11 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)
+12 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=+VAIP(3)
+13 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=QAOSDIAG
+14 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=QAOSD0
+15 QUIT
End DoDot:1
+16 QUIT
