QAOC1011.m

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 ---QAOC1011   1980     printed  Apr 09, 2024@21:23:42                                                                                                                                                                                                    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