QAOC102 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ;6/14/93 07:11
;;3.0;Occurrence Screen;;09/14/1993
;SCREEN 102 -- ADMISSION WITHIN 3 DAYS OF UNSCHEDULED AMBULATORY CARE VISIT
Q:$$INACTIVE^QAOC0(102)
S QAODISPL=3600*$P($G(^QA(740,1,"OS")),"^",6)
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)
S INTYP=$P(QAOSZERO,"^",18) Q:INTYP=40
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:"")
Q:$$TXSP^QAOC0("AS",TXSP)'>0 ; Change "AS" to "ASP" to include psych
S X1=QAOSDT,X2=-4 D C^%DTC
S (SV,VIS,REGEND)=X\1_".24",REGEND=9999999-REGEND,FLG=0,QAOVISIT=""
S QACLINIC=""
G:'$D(^DPT(QAOSDFN,"S",0)) TYPE2
F VIS=VIS:0 S VIS=$O(^DPT(QAOSDFN,"S",VIS)) Q:(VIS'>0)!(VIS>QAOSDT)!(VIS\1=(QAOSDT\1))!(VIS\1'?7N) D:$P(^DPT(QAOSDFN,"S",VIS,0),"^",2)="" LOOP1 Q:FLG
TYPE2 ;
G:FLG FILE
;F SV=SV:0 S SV=$O(^SDV("B",SV)) Q:(SV'>0)!(SV>QAOSDT)!(SV\1=(QAOSDT\1))!(SV\1'?7N) I $D(^SDV(SV,0)),$P(^(0),"^",2)=QAOSDFN S FLG=1,QAOVISIT=SV Q
TYPE3 ;
G FILE:FLG,FILE:'$D(^DPT(QAOSDFN,"DIS",0))
S X1=QAOSDT,X2=-1 D C^%DTC S REG=9999999-(X\1_".24")
F REG=REG:0 S REG=$O(^DPT(QAOSDFN,"DIS",REG)) Q:(REG'>0)!(REG'<REGEND)!(REG\1'?7N) D LOOP2 Q:FLG
FILE ;
D:FLG
. D VADPT^QAOC0(QAOSDFN,QAOSD0)
. S WARDCLIN=+VAIP(5)_"^"_$S(QACLINIC:QACLINIC,1:"")
. S ^UTILITY($J,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""
. 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")=QAOVISIT
. 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
Q
LOOP1 ;
S LOC=^DPT(QAOSDFN,"S",VIS,0) I LOC]"",$P(LOC,"^",7)=4 S FLG=1,QAOVISIT=VIS,QACLINIC=+$P(LOC,"^")
Q
LOOP2 ;
Q:$D(^DPT(QAOSDFN,"DIS",REG,0))[0 S LOC=^(0) Q:$P(LOC,"^",2)>1
S OUT=$P(LOC,"^",6) Q:OUT'>0
S X=QAOSDT D H^%DTC S QAOSH=%H,QAOST=%T,X=OUT
D H^%DTC S QAOSH=QAOSH-%H,QAOST=QAOST-%T
S QAOST=QAOST+(86400*QAOSH) ; TIME BETWEEN ADMISSION & LOG OUT
Q:QAOST<QAODISPL ; QUIT IF TIME < MIN TIME BETWEEN LOG OUT & ADM
S FLG=1,QAOVISIT=9999999-REG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOC102 2621 printed Apr 09, 2024@21:22:27 Page 2
QAOC102 ;HISC/DAD-OCCURRENCE SCREEN AUTO ENROLLMENT ;6/14/93 07:11
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 ;SCREEN 102 -- ADMISSION WITHIN 3 DAYS OF UNSCHEDULED AMBULATORY CARE VISIT
+3 if $$INACTIVE^QAOC0(102)
QUIT
+4 SET QAODISPL=3600*$PIECE($GET(^QA(740,1,"OS")),"^",6)
+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
SET QAOSZERO=$GET(^DGPM(QAOSD0,0))
IF QAOSZERO]""
DO MAIN
+7 QUIT
End DoDot:1
+8 QUIT
MAIN ;
+1 if $$SCHED^QAOC0(QAOSDFN,QAOSDT)
QUIT
+2 SET INTYP=$PIECE(QAOSZERO,"^",18)
if INTYP=40
QUIT
+3 SET SPECDT=+$ORDER(^DGPM("APTT6",QAOSDFN,+QAOSZERO-.0000001))
+4 SET SPECD0=$ORDER(^DGPM("APTT6",QAOSDFN,SPECDT,0))
+5 SET TXSP=$SELECT(SPECD0'>0:"",$DATA(^DGPM(SPECD0,0))#2:$PIECE(^(0),"^",9),1:"")
+6 ; Change "AS" to "ASP" to include psych
if $$TXSP^QAOC0("AS",TXSP)'>0
QUIT
+7 SET X1=QAOSDT
SET X2=-4
DO C^%DTC
+8 SET (SV,VIS,REGEND)=X\1_".24"
SET REGEND=9999999-REGEND
SET FLG=0
SET QAOVISIT=""
+9 SET QACLINIC=""
+10 if '$DATA(^DPT(QAOSDFN,"S",0))
GOTO TYPE2
+11 FOR VIS=VIS:0
SET VIS=$ORDER(^DPT(QAOSDFN,"S",VIS))
if (VIS'>0)!(VIS>QAOSDT)!(VIS\1=(QAOSDT\1))!(VIS\1'?7N)
QUIT
if $PIECE(^DPT(QAOSDFN,"S",VIS,0),"^",2)=""
DO LOOP1
if FLG
QUIT
TYPE2 ;
+1 if FLG
GOTO FILE
+2 ;F SV=SV:0 S SV=$O(^SDV("B",SV)) Q:(SV'>0)!(SV>QAOSDT)!(SV\1=(QAOSDT\1))!(SV\1'?7N) I $D(^SDV(SV,0)),$P(^(0),"^",2)=QAOSDFN S FLG=1,QAOVISIT=SV Q
TYPE3 ;
+1 if FLG
GOTO FILE
if '$DATA(^DPT(QAOSDFN,"DIS",0))
GOTO FILE
+2 SET X1=QAOSDT
SET X2=-1
DO C^%DTC
SET REG=9999999-(X\1_".24")
+3 FOR REG=REG:0
SET REG=$ORDER(^DPT(QAOSDFN,"DIS",REG))
if (REG'>0)!(REG'<REGEND)!(REG\1'?7N)
QUIT
DO LOOP2
if FLG
QUIT
FILE ;
+1 if FLG
Begin DoDot:1
+2 DO VADPT^QAOC0(QAOSDFN,QAOSD0)
+3 SET WARDCLIN=+VAIP(5)_"^"_$SELECT(QACLINIC:QACLINIC,1:"")
+4 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""
+5 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=WARDCLIN
+6 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)
+7 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=QAOVISIT
+8 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=VAIP(9)
+9 SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=VAIP(13)
+10 QUIT
End DoDot:1
+11 QUIT
LOOP1 ;
+1 SET LOC=^DPT(QAOSDFN,"S",VIS,0)
IF LOC]""
IF $PIECE(LOC,"^",7)=4
SET FLG=1
SET QAOVISIT=VIS
SET QACLINIC=+$PIECE(LOC,"^")
+2 QUIT
LOOP2 ;
+1 if $DATA(^DPT(QAOSDFN,"DIS",REG,0))[0
QUIT
SET LOC=^(0)
if $PIECE(LOC,"^",2)>1
QUIT
+2 SET OUT=$PIECE(LOC,"^",6)
if OUT'>0
QUIT
+3 SET X=QAOSDT
DO H^%DTC
SET QAOSH=%H
SET QAOST=%T
SET X=OUT
+4 DO H^%DTC
SET QAOSH=QAOSH-%H
SET QAOST=QAOST-%T
+5 ; TIME BETWEEN ADMISSION & LOG OUT
SET QAOST=QAOST+(86400*QAOSH)
+6 ; QUIT IF TIME < MIN TIME BETWEEN LOG OUT & ADM
if QAOST<QAODISPL
QUIT
+7 SET FLG=1
SET QAOVISIT=9999999-REG
+8 QUIT
