QAOC1011 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ; 6/9/14 1:13pm
;;3.0;Occurrence Screen;**9**;09/14/1993;Build 4
;SCREEN 101.1 -- READMISSION WITHIN 10 DAYS
Q:$$INACTIVE^QAOC0(101.1)
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 S QAOSZERO=$G(^DGPM(QAOSD0,0)) I QAOSZERO]"" D MAIN
. Q
Q
MAIN ;
;Q:$$SCHED^QAOC0(QAOSDFN,QAOSDT)
; Check date and time to see if scheduled or unscheduled admit (QAO*3*9)
Q:$$SCHED2^QAOC0(QAOSDFN,QAOSDT)
S INTYP(0)=$P(QAOSZERO,"^",18)
S INTYP=$S(INTYP(0)'>0:"",$D(^DG(405.2,INTYP(0),0))#2:^(0),1:"")
S SPECDT=+$O(^DGPM("APTT6",QAOSDFN,+QAOSZERO-.0000001))
S SPECD0=$O(^DGPM("APTT6",QAOSDFN,SPECDT,0))
S TXSP=$S(SPECD0'>0:"",$D(^DGPM(SPECD0,0))#2:$P(^(0),"^",9),1:"")
S Y=$$TXSP^QAOC0("ASP",TXSP)
Q:$S(+Y=-1:1,$P(INTYP,"^",2)'=1:1,INTYP(0)'>0:1,1:0)
S QAOSDTP=9999999.9999999-QAOSDT
AGAIN ;
S QAOSDTP=$O(^DGPM("ATID3",QAOSDFN,QAOSDTP))
Q:QAOSDTP'>0!(QAOSDTP\1'?7N)
S QAOSD1P=$O(^DGPM("ATID3",QAOSDFN,QAOSDTP,0))
S QAOSZERO(0)=$S(QAOSD1P'>0:"",$D(^DGPM(QAOSD1P,0))#2:^(0),1:"")
G:QAOSZERO(0)="" AGAIN
S OUTIMP=+QAOSZERO(0),OUTYPP=$P(QAOSZERO(0),"^",18)
S X1=$P(QAOSZERO,"^")\1,X2=OUTIMP\1 D ^%DTC Q:X>10
I OUTYPP>0,$D(^DG(405.2,OUTYPP,0))#2,$P(^(0),"^",8)=4 G AGAIN
D VADPT^QAOC0(QAOSDFN,QAOSD1P)
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")=OUTIMP
D VADPT^QAOC0(QAOSDFN,QAOSD0)
S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=VAIP(9)
S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=VAIP(13)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOC1011 1980 printed Nov 22, 2024@17:30:58 Page 2
QAOC1011 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ; 6/9/14 1:13pm
+1 ;;3.0;Occurrence Screen;**9**;09/14/1993;Build 4
+2 ;SCREEN 101.1 -- READMISSION WITHIN 10 DAYS
+3 if $$INACTIVE^QAOC0(101.1)
QUIT
+4 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
+5 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^DGPM("AMV1",QAOSDT,QAOSDFN,QAOSD0))
if QAOSD0'>0
QUIT
SET QAOSZERO=$GET(^DGPM(QAOSD0,0))
IF QAOSZERO]""
DO MAIN
+6 QUIT
End DoDot:1
+7 QUIT
MAIN ;
+1 ;Q:$$SCHED^QAOC0(QAOSDFN,QAOSDT)
+2 ; Check date and time to see if scheduled or unscheduled admit (QAO*3*9)
+3 if $$SCHED2^QAOC0(QAOSDFN,QAOSDT)
QUIT
+4 SET INTYP(0)=$PIECE(QAOSZERO,"^",18)
+5 SET INTYP=$SELECT(INTYP(0)'>0:"",$DATA(^DG(405.2,INTYP(0),0))#2:^(0),1:"")
+6 SET SPECDT=+$ORDER(^DGPM("APTT6",QAOSDFN,+QAOSZERO-.0000001))
+7 SET SPECD0=$ORDER(^DGPM("APTT6",QAOSDFN,SPECDT,0))
+8 SET TXSP=$SELECT(SPECD0'>0:"",$DATA(^DGPM(SPECD0,0))#2:$PIECE(^(0),"^",9),1:"")
+9 SET Y=$$TXSP^QAOC0("ASP",TXSP)
+10 if $SELECT(+Y=-1
QUIT
+11 SET QAOSDTP=9999999.9999999-QAOSDT
AGAIN ;
+1 SET QAOSDTP=$ORDER(^DGPM("ATID3",QAOSDFN,QAOSDTP))
+2 if QAOSDTP'>0!(QAOSDTP\1'?7N)
QUIT
+3 SET QAOSD1P=$ORDER(^DGPM("ATID3",QAOSDFN,QAOSDTP,0))
+4 SET QAOSZERO(0)=$SELECT(QAOSD1P'>0:"",$DATA(^DGPM(QAOSD1P,0))#2:^(0),1:"")
+5 if QAOSZERO(0)=""
GOTO AGAIN
+6 SET OUTIMP=+QAOSZERO(0)
SET OUTYPP=$PIECE(QAOSZERO(0),"^",18)
+7 SET X1=$PIECE(QAOSZERO,"^")\1
SET X2=OUTIMP\1
DO ^%DTC
if X>10
QUIT
+8 IF OUTYPP>0
IF $DATA(^DG(405.2,OUTYPP,0))#2
IF $PIECE(^(0),"^",8)=4
GOTO AGAIN
+9 DO VADPT^QAOC0(QAOSDFN,QAOSD1P)
+10 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""
+11 SET WARDCLIN=+VAIP(5)_"^"
+12 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=WARDCLIN
+13 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)
+14 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=OUTIMP
+15 DO VADPT^QAOC0(QAOSDFN,QAOSD0)
+16 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=VAIP(9)
+17 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=VAIP(13)
+18 QUIT
