- 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 Mar 13, 2025@21:25:57 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
