QAOSSFR0 ;HISC/DAD-OCCURRENCE SCREEN / MONITORING SYSTEM AUTO ENROLL SPECIAL FUNCTIONS ROUTINE ;6/29/93 09:31
;;3.0;Occurrence Screen;;09/14/1993
K ^TMP("QAO",$J)
S QAOSSCRN=+$O(^QA(741.1,"AM",QAMD0,0)) G:QAOSSCRN'>0 EXIT
S QAOS740=$G(^QA(740,1,"OS"))
F QAOSDFN=0:0 S QAOSDFN=$O(^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN)) Q:QAOSDFN'>0 F QAOSDATE=0:0 S QAOSDATE=$O(^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE)) Q:QAOSDATE'>0!(QAOSDATE\1'?7N) D LOOP1
F QAOSSCR=0:0 S QAOSSCR=$O(^QA(741.1,QAOSSCR)) Q:(QAOSSCR'>0)!(QAOSSCR'<200) I $P($G(^QA(741.1,QAOSSCR,0)),"^",4)'>0 S QAOSTOT(QAOSSCR)=0
F QAOSDT=QAMTODAY-.0000001:0 S QAOSDT=$O(^QA(741,"ARCD",QAOSDT)) Q:(QAOSDT'>0)!(QAOSDT>(QAMTODAY+.24))!(QAOSDT\1'?7N) F QAOSS0=0:0 S QAOSS0=$O(^QA(741,"ARCD",QAOSDT,QAOSS0)) Q:QAOSS0'>0 D
. S QAOSSCR=+$G(^QA(741,QAOSS0,"SCRN"))
. Q:(QAOSSCR'>0)!(QAOSSCR'<200) Q:$D(QAOSTOT(QAOSSCR))[0
. S QAOSTOT(QAOSSCR)=QAOSTOT(QAOSSCR)+1
. Q
K DD,DIC,DINUM,DO S DIC="^QA(741.99,",DIC(0)="LMN",DLAYGO=741.99
S X=QAMTODAY D ^DIC S QAO74199=+Y
K DR S DIE="^QA(741.99,",DA=QAO74199,DR=""
F QAOSSCR=0:0 S QAOSSCR=$O(QAOSTOT(QAOSSCR)) Q:QAOSSCR'>0 D
. S QA=$P($T(@(10*QAOSSCR\1)),";;",2)
. S DR=DR_$S(QA]"":$E(";",DR]"")_QA_"///"_QAOSTOT(QAOSSCR),1:"")
. Q
I DR]"" D ^DIE
D PRINT^QAOSSFR1
EXIT ;
K ^TMP("QAO",$J)
K %DT,DA,DD,DFN,DIC,DIE,DINUM,DLAYGO,DO,DR,PAGE,QAO74199,QAOCOUNT
K QAOSD0,QAOSDATA,QAOSDATE,QAOSDFN,QAOSDIAG,QAOSDT,QAOSDUP
K QAOSMVDT,QAOSPAT,QAOSPID,QAOSQUIT,QAOSS0,QAOSSCR,QAOSSCRN
K QAOSSERV,QAOSTOT,QAOSTXSP,QAOSWARD,QAUDIT,TODAY,UNDL,VA,X,Y
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
;
LOOP1 ;
S QAOSDFN(0)=$S($D(^DPT(QAOSDFN,0))#2:$P(^(0),"^"),1:QAOSDFN)
S QAOSWARD=$G(^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"WARD"))
S QAOSDIVN=$P($G(^DIC(42,+QAOSWARD,0)),"^",11)
S QAOSDIVN=$S($D(^DG(40.8,+QAOSDIVN,0))#2:QAOSDIVN,1:"*")
I $P(QAOSWARD,"^",2) S QAOSWARD=+$P(QAOSWARD,"^",2)
E S QAOSWARD=+$P($G(^DIC(42,+QAOSWARD,44)),"^")
S X=$G(^SC(+QAOSWARD,0)),QAOSWARD=$S(X]"":QAOSWARD,1:"")
S QAOSWARD=$S(QAOSWARD'>0:"","^C^W^"[("^"_$P(X,"^",3)_"^"):+QAOSWARD,1:"")
S QAOSTXSP=$G(^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"TXSP"))
S QAOSTXSP=$S(QAOSTXSP'>0:"",$D(^DIC(45.7,+QAOSTXSP,0))#2:+QAOSTXSP,1:"")
S QAOSSERV=$P($G(^DIC(45.7,+QAOSTXSP,0)),"^",4)
S QAOSSERV=$S(QAOSSERV'>0:"",$D(^DIC(49,+QAOSSERV,0))#2:+QAOSSERV,1:"")
S QAOSDIAG=$G(^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"DIAG"))
S QAOSMVDT=$G(^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"MVDT"))
S QAOSAADM=$G(^UTILITY($J,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"AADM"))
S QAOSAADM=$S(QAOSDATE\1'<($P($G(^DGPM(+QAOSAADM,0)),"^")\1):QAOSAADM,1:"")
S QAOSDUP=0,QAOSD0=+$O(^QA(741,"AA",QAOSSCRN,QAOSDATE,QAOSDFN,0))
I QAOSD0 S QAOSDUP=1 G INFILE
K DD,DIC,DINUM,DO S DIC="^QA(741,",DIC(0)="L",DLAYGO=741,X=QAOSDFN
D FILE^DICN S QAOSD0=+Y
S DIE="^QA(741,",DA=QAOSD0
S DR="1///^S X=QAOSDATE;3///`"_QAOSSCRN_";11///^S X=0;28///^S X=QAMTODAY"
S:QAOSAADM DR=DR_";.02///`"_QAOSAADM
S:QAOSWARD DR=DR_";4///`"_QAOSWARD
S:QAOSSERV DR=DR_";5///`"_QAOSSERV
S:QAOSTXSP DR=DR_";6///`"_QAOSTXSP
S:QAOSSCRN=109 DR=DR_";19///3"
D ^DIE
S QAUDIT("FILE")="741^27",QAUDIT("DA")=QAOSD0,QAUDIT("ACTION")="o"
S QAUDIT("COMMENT")="AUTO ENROLLED OCCURRENCE" D ^QAQAUDIT
S ^TMP("QAO",$J,"WKS",QAOSDIVN,QAOSDFN(0),QAOSD0)=""
INFILE S DFN=QAOSDFN D PID^VADPT6 S QAOSPID=VA("PID")
S ^TMP("QAO",$J,"RPT",QAOSDIVN,$E("*",QAOSDUP)_QAOSDFN(0),QAOSD0)=QAOSPID_"^"_QAOSWARD_"^"_QAOSDIAG_"^"_QAOSMVDT
Q
SCRN ;;TOTAL FIELD FOR EACH SCREEN IN FILE #741.99
1010 ;;1
1011 ;;1.1
1020 ;;2
1030 ;;3
1041 ;;4.1
1042 ;;4.2
1051 ;;5.1
1052 ;;5.2
1061 ;;6.1
1062 ;;6.2
1070 ;;7
1080 ;;8
1090 ;;9
1990 ;;99
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSSFR0 3776 printed Dec 13, 2024@02:22:09 Page 2
QAOSSFR0 ;HISC/DAD-OCCURRENCE SCREEN / MONITORING SYSTEM AUTO ENROLL SPECIAL FUNCTIONS ROUTINE ;6/29/93 09:31
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 KILL ^TMP("QAO",$JOB)
+3 SET QAOSSCRN=+$ORDER(^QA(741.1,"AM",QAMD0,0))
if QAOSSCRN'>0
GOTO EXIT
+4 SET QAOS740=$GET(^QA(740,1,"OS"))
+5 FOR QAOSDFN=0:0
SET QAOSDFN=$ORDER(^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN))
if QAOSDFN'>0
QUIT
FOR QAOSDATE=0:0
SET QAOSDATE=$ORDER(^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE))
if QAOSDATE'>0!(QAOSDATE\1'?7N)
QUIT
DO LOOP1
+6 FOR QAOSSCR=0:0
SET QAOSSCR=$ORDER(^QA(741.1,QAOSSCR))
if (QAOSSCR'>0)!(QAOSSCR'<200)
QUIT
IF $PIECE($GET(^QA(741.1,QAOSSCR,0)),"^",4)'>0
SET QAOSTOT(QAOSSCR)=0
+7 FOR QAOSDT=QAMTODAY-.0000001:0
SET QAOSDT=$ORDER(^QA(741,"ARCD",QAOSDT))
if (QAOSDT'>0)!(QAOSDT>(QAMTODAY+.24))!(QAOSDT\1'?7N)
QUIT
FOR QAOSS0=0:0
SET QAOSS0=$ORDER(^QA(741,"ARCD",QAOSDT,QAOSS0))
if QAOSS0'>0
QUIT
Begin DoDot:1
+8 SET QAOSSCR=+$GET(^QA(741,QAOSS0,"SCRN"))
+9 if (QAOSSCR'>0)!(QAOSSCR'<200)
QUIT
if $DATA(QAOSTOT(QAOSSCR))[0
QUIT
+10 SET QAOSTOT(QAOSSCR)=QAOSTOT(QAOSSCR)+1
+11 QUIT
End DoDot:1
+12 KILL DD,DIC,DINUM,DO
SET DIC="^QA(741.99,"
SET DIC(0)="LMN"
SET DLAYGO=741.99
+13 SET X=QAMTODAY
DO ^DIC
SET QAO74199=+Y
+14 KILL DR
SET DIE="^QA(741.99,"
SET DA=QAO74199
SET DR=""
+15 FOR QAOSSCR=0:0
SET QAOSSCR=$ORDER(QAOSTOT(QAOSSCR))
if QAOSSCR'>0
QUIT
Begin DoDot:1
+16 SET QA=$PIECE($TEXT(@(10*QAOSSCR\1)),";;",2)
+17 SET DR=DR_$SELECT(QA]"":$EXTRACT(";",DR]"")_QA_"///"_QAOSTOT(QAOSSCR),1:"")
+18 QUIT
End DoDot:1
+19 IF DR]""
DO ^DIE
+20 DO PRINT^QAOSSFR1
EXIT ;
+1 KILL ^TMP("QAO",$JOB)
+2 KILL %DT,DA,DD,DFN,DIC,DIE,DINUM,DLAYGO,DO,DR,PAGE,QAO74199,QAOCOUNT
+3 KILL QAOSD0,QAOSDATA,QAOSDATE,QAOSDFN,QAOSDIAG,QAOSDT,QAOSDUP
+4 KILL QAOSMVDT,QAOSPAT,QAOSPID,QAOSQUIT,QAOSS0,QAOSSCR,QAOSSCRN
+5 KILL QAOSSERV,QAOSTOT,QAOSTXSP,QAOSWARD,QAUDIT,TODAY,UNDL,VA,X,Y
+6 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+7 QUIT
+8 ;
LOOP1 ;
+1 SET QAOSDFN(0)=$SELECT($DATA(^DPT(QAOSDFN,0))#2:$PIECE(^(0),"^"),1:QAOSDFN)
+2 SET QAOSWARD=$GET(^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"WARD"))
+3 SET QAOSDIVN=$PIECE($GET(^DIC(42,+QAOSWARD,0)),"^",11)
+4 SET QAOSDIVN=$SELECT($DATA(^DG(40.8,+QAOSDIVN,0))#2:QAOSDIVN,1:"*")
+5 IF $PIECE(QAOSWARD,"^",2)
SET QAOSWARD=+$PIECE(QAOSWARD,"^",2)
+6 IF '$TEST
SET QAOSWARD=+$PIECE($GET(^DIC(42,+QAOSWARD,44)),"^")
+7 SET X=$GET(^SC(+QAOSWARD,0))
SET QAOSWARD=$SELECT(X]"":QAOSWARD,1:"")
+8 SET QAOSWARD=$SELECT(QAOSWARD'>0:"","^C^W^"[("^"_$PIECE(X,"^",3)_"^"):+QAOSWARD,1:"")
+9 SET QAOSTXSP=$GET(^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"TXSP"))
+10 SET QAOSTXSP=$SELECT(QAOSTXSP'>0:"",$DATA(^DIC(45.7,+QAOSTXSP,0))#2:+QAOSTXSP,1:"")
+11 SET QAOSSERV=$PIECE($GET(^DIC(45.7,+QAOSTXSP,0)),"^",4)
+12 SET QAOSSERV=$SELECT(QAOSSERV'>0:"",$DATA(^DIC(49,+QAOSSERV,0))#2:+QAOSSERV,1:"")
+13 SET QAOSDIAG=$GET(^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"DIAG"))
+14 SET QAOSMVDT=$GET(^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"MVDT"))
+15 SET QAOSAADM=$GET(^UTILITY($JOB,"QAM FALL OUT",QAMD0,QAOSDFN,QAOSDATE,"AADM"))
+16 SET QAOSAADM=$SELECT(QAOSDATE\1'<($PIECE($GET(^DGPM(+QAOSAADM,0)),"^")\1):QAOSAADM,1:"")
+17 SET QAOSDUP=0
SET QAOSD0=+$ORDER(^QA(741,"AA",QAOSSCRN,QAOSDATE,QAOSDFN,0))
+18 IF QAOSD0
SET QAOSDUP=1
GOTO INFILE
+19 KILL DD,DIC,DINUM,DO
SET DIC="^QA(741,"
SET DIC(0)="L"
SET DLAYGO=741
SET X=QAOSDFN
+20 DO FILE^DICN
SET QAOSD0=+Y
+21 SET DIE="^QA(741,"
SET DA=QAOSD0
+22 SET DR="1///^S X=QAOSDATE;3///`"_QAOSSCRN_";11///^S X=0;28///^S X=QAMTODAY"
+23 if QAOSAADM
SET DR=DR_";.02///`"_QAOSAADM
+24 if QAOSWARD
SET DR=DR_";4///`"_QAOSWARD
+25 if QAOSSERV
SET DR=DR_";5///`"_QAOSSERV
+26 if QAOSTXSP
SET DR=DR_";6///`"_QAOSTXSP
+27 if QAOSSCRN=109
SET DR=DR_";19///3"
+28 DO ^DIE
+29 SET QAUDIT("FILE")="741^27"
SET QAUDIT("DA")=QAOSD0
SET QAUDIT("ACTION")="o"
+30 SET QAUDIT("COMMENT")="AUTO ENROLLED OCCURRENCE"
DO ^QAQAUDIT
+31 SET ^TMP("QAO",$JOB,"WKS",QAOSDIVN,QAOSDFN(0),QAOSD0)=""
INFILE SET DFN=QAOSDFN
DO PID^VADPT6
SET QAOSPID=VA("PID")
+1 SET ^TMP("QAO",$JOB,"RPT",QAOSDIVN,$EXTRACT("*",QAOSDUP)_QAOSDFN(0),QAOSD0)=QAOSPID_"^"_QAOSWARD_"^"_QAOSDIAG_"^"_QAOSMVDT
+2 QUIT
SCRN ;;TOTAL FIELD FOR EACH SCREEN IN FILE #741.99
1010 ;;1
1011 ;;1.1
1020 ;;2
1030 ;;3
1041 ;;4.1
1042 ;;4.2
1051 ;;5.1
1052 ;;5.2
1061 ;;6.1
1062 ;;6.2
1070 ;;7
1080 ;;8
1090 ;;9
1990 ;;99
