Routine: QAOC107

QAOC107 ;HISC/DAD - OCCURRENCE SCREEN AUTO ENROLLMENT ;8/12/93  09:06

 ;;3.0;Occurrence Screen;**10**;09/14/1993;Build 5

 ;SCREEN 107 -- RETURN TO THE O.R. IN THE SAME ADMISSION (SURGERY V3.0)

 Q:$$INACTIVE^QAOC0(107)  Q:$P($G(^QA(740,1,"OS")),"^",7)'>0

 K QAOSFALL

 F QAOSDT=QAMTODAY-.0000001:0 S QAOSDT=$O(^SRF("AC",QAOSDT)) Q:(QAOSDT'>0)!(QAOSDT>(QAMTODAY+.24))!(QAOSDT\1'?7N)  F QAOSRFD0=0:0 S QAOSRFD0=$O(^SRF("AC",QAOSDT,QAOSRFD0)) Q:QAOSRFD0'>0  D MAIN

 K %Y,DFN,QAOSADM,QAOSCHED,QAOSDFN,QAOSDT,QAOSDTP,QAOSFALL,QAOSRF0

 K QAOSRF30,QAOSRF31,QAOSRFD0,QAOSRFDA,QAOSVAIP,X,X1,X2

 K ^UTILITY($J,"QAM TEMP") D KVAR^VADPT

MAIN ;

 S QAOSRF0=$G(^SRF(QAOSRFD0,0)),QAOSDFN=+QAOSRF0

 Q:$S(QAOSDFN'>0:1,$D(QAOSFALL(QAOSDFN))#2:1,1:0)

 Q:$S($P(QAOSRF0,U,12)="":1,$P(QAOSRF0,U,12)="O":1,1:0)  ;QAO*3.0*10 - updated due to surgery enhancements

 S QAOSRF30=$G(^SRF(QAOSRFD0,30)),QAOSRF31=$G(^(31))

 Q:$S($P(QAOSRF30,"^"):1,$P(QAOSRF31,"^",8):1,1:0)

 S QAOSCHED=$P(QAOSRF31,"^",4)

 K VAIP S DFN=QAOSDFN,VAIP("D")=QAOSDT\1,VAIP("M")=0 D IN5^VADPT

 S QAOSVAIP(1)=VAIP(1),QAOSVAIP(9)=VAIP(9)

 S QAOSADM=+VAIP(3)\1 Q:QAOSADM'>0

 S X1=QAOSDT\1,X2=QAOSADM D ^%DTC

 I X>7 S X1=QAOSDT\1,X2=-7 D C^%DTC S QAOSADM=X

 S QAOSDTP=9999999-QAOSDT-.0000001,QAOSQUIT=0

 F QAOSDTP=QAOSDTP:0 S QAOSDTP=$O(^SRF("ADT",QAOSDFN,QAOSDTP)) Q:(QAOSDTP'>0)!(QAOSDTP\1'?7N)!QAOSQUIT  D

 . F QAOSRFDA=0:0 S QAOSRFDA=$O(^SRF("ADT",QAOSDFN,QAOSDTP,QAOSRFDA)) Q:(QAOSRFDA'>0)!(QAOSRFDA=QAOSRFD0)!QAOSQUIT  D

 .. S QAOSRF0=$G(^SRF(QAOSRFDA,0))

 .. S QAOSDTP(0)=$P(QAOSRF0,"^",9)

 .. I (QAOSDTP(0)<QAOSADM)!(QAOSDTP(0)'<QAOSDT) S QAOSQUIT=1 Q

 .. Q:$S($P(QAOSRF0,U,12)="":1,$P(QAOSRF0,U,12)="O":1,1:0)  ;QAO*3.0*10 - updated due to surgery enhancements

 .. S QAOSRF30(0)=$G(^SRF(QAOSRFD0,30)),QAOSRF31(0)=$G(^(31))

 .. Q:$S($P(QAOSRF30(0),"^"):1,$P(QAOSRF31(0),"^",8):1,1:0)

 .. I QAOSCHED,QAOSCHED\1'>(QAOSDTP(0)\1) Q

 .. I $P($G(^SRF(QAOSRFDA,29,QAOSRFD0,0)),"^",3)'="R" Q

 .. K VAIP S DFN=QAOSDFN,VAIP("D")=QAOSDTP(0)\1,VAIP("M")=0

 .. D IN5^VADPT

 .. S (QAOSFALL(QAOSDFN),QAOSQUIT)=1

 .. S ^UTILITY($J,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""

 .. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=+VAIP(5)

 .. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)

 .. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=QAOSDTP(0)

 .. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=QAOSVAIP(9)

 .. S ^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=+QAOSVAIP(1)

 .. Q

. Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOC107   2545     printed  Apr 09, 2024@21:22:45                                                                                                                                                                                                     Page 2

QAOC107   ;HISC/DAD - OCCURRENCE SCREEN AUTO ENROLLMENT ;8/12/93  09:06

 +1       ;;3.0;Occurrence Screen;**10**;09/14/1993;Build 5

 +2       ;SCREEN 107 -- RETURN TO THE O.R. IN THE SAME ADMISSION (SURGERY V3.0)

 +3        if $$INACTIVE^QAOC0(107)

               QUIT

           if $PIECE($GET(^QA(740,1,"OS")),"^",7)'>0

               QUIT

 +4        KILL QAOSFALL

 +5        FOR QAOSDT=QAMTODAY-.0000001:0

               SET QAOSDT=$ORDER(^SRF("AC",QAOSDT))

               if (QAOSDT'>0)!(QAOSDT>(QAMTODAY+.24))!(QAOSDT\1'?7N)

                   QUIT

               FOR QAOSRFD0=0:0

                   SET QAOSRFD0=$ORDER(^SRF("AC",QAOSDT,QAOSRFD0))

                   if QAOSRFD0'>0

                       QUIT

                   DO MAIN

 +6        KILL %Y,DFN,QAOSADM,QAOSCHED,QAOSDFN,QAOSDT,QAOSDTP,QAOSFALL,QAOSRF0

 +7        KILL QAOSRF30,QAOSRF31,QAOSRFD0,QAOSRFDA,QAOSVAIP,X,X1,X2

 +8        KILL ^UTILITY($JOB,"QAM TEMP")

           DO KVAR^VADPT

 +9        QUIT

MAIN      ;

 +1        SET QAOSRF0=$GET(^SRF(QAOSRFD0,0))

           SET QAOSDFN=+QAOSRF0

 +2        if $SELECT(QAOSDFN'>0

               QUIT

 +3       ;QAO*3.0*10 - updated due to surgery enhancements

           if $SELECT($PIECE(QAOSRF0,U,12)=""

               QUIT

 +4        SET QAOSRF30=$GET(^SRF(QAOSRFD0,30))

           SET QAOSRF31=$GET(^(31))

 +5        if $SELECT($PIECE(QAOSRF30,"^")

               QUIT

 +6        SET QAOSCHED=$PIECE(QAOSRF31,"^",4)

 +7        KILL VAIP

           SET DFN=QAOSDFN

           SET VAIP("D")=QAOSDT\1

           SET VAIP("M")=0

           DO IN5^VADPT

 +8        SET QAOSVAIP(1)=VAIP(1)

           SET QAOSVAIP(9)=VAIP(9)

 +9        SET QAOSADM=+VAIP(3)\1

           if QAOSADM'>0

               QUIT

 +10       SET X1=QAOSDT\1

           SET X2=QAOSADM

           DO ^%DTC

 +11       IF X>7

               SET X1=QAOSDT\1

               SET X2=-7

               DO C^%DTC

               SET QAOSADM=X

 +12      ;

 +13       SET QAOSDTP=9999999-QAOSDT-.0000001

           SET QAOSQUIT=0

 +14       FOR QAOSDTP=QAOSDTP:0

               SET QAOSDTP=$ORDER(^SRF("ADT",QAOSDFN,QAOSDTP))

               if (QAOSDTP'>0)!(QAOSDTP\1'?7N)!QAOSQUIT

                   QUIT

               Begin DoDot:1

 +15               FOR QAOSRFDA=0:0

                       SET QAOSRFDA=$ORDER(^SRF("ADT",QAOSDFN,QAOSDTP,QAOSRFDA))

                       if (QAOSRFDA'>0)!(QAOSRFDA=QAOSRFD0)!QAOSQUIT

                           QUIT

                       Begin DoDot:2

 +16                       SET QAOSRF0=$GET(^SRF(QAOSRFDA,0))

 +17                       SET QAOSDTP(0)=$PIECE(QAOSRF0,"^",9)

 +18                       IF (QAOSDTP(0)<QAOSADM)!(QAOSDTP(0)'<QAOSDT)

                               SET QAOSQUIT=1

                               QUIT

 +19      ;QAO*3.0*10 - updated due to surgery enhancements

                           if $SELECT($PIECE(QAOSRF0,U,12)=""

                               QUIT

 +20                       SET QAOSRF30(0)=$GET(^SRF(QAOSRFD0,30))

                           SET QAOSRF31(0)=$GET(^(31))

 +21                       if $SELECT($PIECE(QAOSRF30(0),"^")

                               QUIT

 +22                       IF QAOSCHED

                               IF QAOSCHED\1'>(QAOSDTP(0)\1)

                                   QUIT

 +23                       IF $PIECE($GET(^SRF(QAOSRFDA,29,QAOSRFD0,0)),"^",3)'="R"

                               QUIT

 +24                       KILL VAIP

                           SET DFN=QAOSDFN

                           SET VAIP("D")=QAOSDTP(0)\1

                           SET VAIP("M")=0

 +25                       DO IN5^VADPT

 +26                       SET (QAOSFALL(QAOSDFN),QAOSQUIT)=1

 +27                       SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAOSDFN,QAMTODAY)=""

 +28                       SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"WARD")=+VAIP(5)

 +29                       SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"TXSP")=+VAIP(8)

 +30                       SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"MVDT")=QAOSDTP(0)

 +31                       SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"DIAG")=QAOSVAIP(9)

 +32                       SET ^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAMTODAY,"AADM")=+QAOSVAIP(1)

 +33                       QUIT

                       End DoDot:2

 +34               QUIT

               End DoDot:1

 +35       QUIT

QAOC107.m