QAOSPSS0 ;HISC/DAD-OCCURRENCE SERVICE STATISTICS SORT ;2/16/93 11:41
;;3.0;Occurrence Screen;;09/14/1993
K ^UTILITY($J,"QAOSPSS"),^UTILITY($J,"QAOSXREF"),^UTILITY($J,"QAOQIP")
S QAOSCLIN=+$O(^QA(741.2,"C",1,0)),QAOSEXCP=+$O(^QA(741.6,"B",3,0)),QAOSLIST=""
F QA=1:1:$L(QAOSLIST(0),",") S QAO=$P(QAOSLIST(0),",",QA),QAOSLIST=QAOSLIST_$S(QAO="1":"^N",QAO=2:"^L",QAO=3:"^1",1:"^")
S QAOS=$P(^DD(42,.03,0),"^",3)_"~:~UNKNOWN;" K QAOSSERV F QA=1:1:$L(QAOS,";")-1 S X=$P(QAOS,";",QA),QAOSSERV($P(X,":",2))=$P(X,":",1)
S QAOS="",QA=1 F QAOS(0)=0:0 S QAOS=$O(QAOSSERV(QAOS)) Q:QAOS="" S X=QAOSSERV(QAOS),QAOSSERV(X)=QAOS_"^"_QA,QA=QA+1 K QAOSSERV(QAOS)
S (QAOSSEQ("L"),QAOSSEQ("N"),QAOSSEQ("1"))=1 F QAOSCRN=0:0 S QAOSCRN=$O(^QA(741.1,"B",QAOSCRN)) Q:QAOSCRN'>0 F QAOSD0=0:0 S QAOSD0=$O(^QA(741.1,"B",QAOSCRN,QAOSD0)) Q:QAOSD0'>0 D LOOP0
F QAOSDATE=QAQNBEG-.0000001:0 S QAOSDATE=$O(^QA(741,"C",QAOSDATE)) Q:(QAOSDATE'>0)!(QAOSDATE>(QAQNEND+.9999999)) F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDATE,QAOSD0)) Q:QAOSD0'>0 D LOOP1
Q
LOOP0 ;
; ^UTILITY($J,"QAOSXREF",SCREEN#)=SEQUENCE# ^ STATUS
S QAOSSCRN=$G(^QA(741.1,QAOSD0,0)),QAOSTYPE=$P(QAOSSCRN,"^",4) Q:QAOSLIST'[("^"_QAOSTYPE_"^")
I QAOSSORT="S" S QA="" F QA(0)=0:0 S QA=$O(QAOSSERV(QA)) Q:QA="" S ^UTILITY($J,"QAOSPSS",QAOSTYPE,$P(QAOSSERV(QA),"^"),QAOSSEQ(QAOSTYPE))=+QAOSSCRN_"^0"
I QAOSSORT="C" S ^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ(QAOSTYPE))=+QAOSSCRN_"^0^0^0^0^0^0^0^0^0^0^0^0"
S ^UTILITY($J,"QAOSXREF",+QAOSSCRN)=QAOSSEQ(QAOSTYPE)_"^"_QAOSTYPE,QAOSSEQ(QAOSTYPE)=QAOSSEQ(QAOSTYPE)+1
Q
LOOP1 ;
S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:QAOSZERO=""!($P(QAOSZERO,"^",11)=2)
S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN")) Q:QAOSSCRN'>0 S QAOSSCRN(0)=+$G(^QA(741.1,QAOSSCRN,0)) Q:QAOSSCRN(0)'>0
S QAOSD1=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0)),QAOSFIND=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5) Q:QAOSFIND=QAOSEXCP
S QAOS=$G(^UTILITY($J,"QAOSXREF",QAOSSCRN(0))),QAOSSEQ=+QAOS,QAOSTYPE=$P(QAOS,"^",2) Q:QAOSLIST'[("^"_QAOSTYPE_"^")
S QAOSHIEN=+$P(QAOSZERO,"^",5)
S QAOSHIEN(0)=$G(^SC(QAOSHIEN,0))
I $P(QAOSHIEN(0),"^",3)="C" D
. S QAOSSERV(0)=$P(QAOSHIEN(0),"^",8)
. S:QAOSSERV(0)="N" QAOSSERV(0)="NE"
. S:QAOSSERV(0)="0" QAOSSERV(0)="~"
. Q
E D
. S QAOSWIEN=+$G(^SC(QAOSHIEN,42))
. S QAOSSERV(0)=$P($G(^DIC(42,QAOSWIEN,0)),"^",3)
. Q
S:QAOSSERV(0)="" QAOSSERV(0)="~"
S QAOSSERV=$S($D(QAOSSERV(QAOSSERV(0)))#2:$P(QAOSSERV(QAOSSERV(0)),"^"),1:"~UNKNOWN")
D SERVICE:QAOSSORT="S",CRITERIA:QAOSSORT="C"
Q
SERVICE ;
S QAOSTEMP=^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSERV,QAOSSEQ),$P(QAOSTEMP,"^",2)=$P(QAOSTEMP,"^",2)+1,^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSERV,QAOSSEQ)=QAOSTEMP
Q
CRITERIA ;
S QAOPIECE=$P(QAOSSERV(QAOSSERV(0)),"^",2)+1,QAOSTEMP=^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ),$P(QAOSTEMP,"^",QAOPIECE)=$P(QAOSTEMP,"^",QAOPIECE)+1,^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ)=QAOSTEMP
S ^UTILITY($J,"QAOQIP",QAOSTYPE,QAOSSEQ,QAOSSERV(0),QAOSD0)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPSS0 2975 printed Dec 13, 2024@02:22:01 Page 2
QAOSPSS0 ;HISC/DAD-OCCURRENCE SERVICE STATISTICS SORT ;2/16/93 11:41
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 KILL ^UTILITY($JOB,"QAOSPSS"),^UTILITY($JOB,"QAOSXREF"),^UTILITY($JOB,"QAOQIP")
+3 SET QAOSCLIN=+$ORDER(^QA(741.2,"C",1,0))
SET QAOSEXCP=+$ORDER(^QA(741.6,"B",3,0))
SET QAOSLIST=""
+4 FOR QA=1:1:$LENGTH(QAOSLIST(0),",")
SET QAO=$PIECE(QAOSLIST(0),",",QA)
SET QAOSLIST=QAOSLIST_$SELECT(QAO="1":"^N",QAO=2:"^L",QAO=3:"^1",1:"^")
+5 SET QAOS=$PIECE(^DD(42,.03,0),"^",3)_"~:~UNKNOWN;"
KILL QAOSSERV
FOR QA=1:1:$LENGTH(QAOS,";")-1
SET X=$PIECE(QAOS,";",QA)
SET QAOSSERV($PIECE(X,":",2))=$PIECE(X,":",1)
+6 SET QAOS=""
SET QA=1
FOR QAOS(0)=0:0
SET QAOS=$ORDER(QAOSSERV(QAOS))
if QAOS=""
QUIT
SET X=QAOSSERV(QAOS)
SET QAOSSERV(X)=QAOS_"^"_QA
SET QA=QA+1
KILL QAOSSERV(QAOS)
+7 SET (QAOSSEQ("L"),QAOSSEQ("N"),QAOSSEQ("1"))=1
FOR QAOSCRN=0:0
SET QAOSCRN=$ORDER(^QA(741.1,"B",QAOSCRN))
if QAOSCRN'>0
QUIT
FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741.1,"B",QAOSCRN,QAOSD0))
if QAOSD0'>0
QUIT
DO LOOP0
+8 FOR QAOSDATE=QAQNBEG-.0000001:0
SET QAOSDATE=$ORDER(^QA(741,"C",QAOSDATE))
if (QAOSDATE'>0)!(QAOSDATE>(QAQNEND+.9999999))
QUIT
FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741,"C",QAOSDATE,QAOSD0))
if QAOSD0'>0
QUIT
DO LOOP1
+9 QUIT
LOOP0 ;
+1 ; ^UTILITY($J,"QAOSXREF",SCREEN#)=SEQUENCE# ^ STATUS
+2 SET QAOSSCRN=$GET(^QA(741.1,QAOSD0,0))
SET QAOSTYPE=$PIECE(QAOSSCRN,"^",4)
if QAOSLIST'[("^"_QAOSTYPE_"^")
QUIT
+3 IF QAOSSORT="S"
SET QA=""
FOR QA(0)=0:0
SET QA=$ORDER(QAOSSERV(QA))
if QA=""
QUIT
SET ^UTILITY($JOB,"QAOSPSS",QAOSTYPE,$PIECE(QAOSSERV(QA),"^"),QAOSSEQ(QAOSTYPE))=+QAOSSCRN_"^0"
+4 IF QAOSSORT="C"
SET ^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSEQ(QAOSTYPE))=+QAOSSCRN_"^0^0^0^0^0^0^0^0^0^0^0^0"
+5 SET ^UTILITY($JOB,"QAOSXREF",+QAOSSCRN)=QAOSSEQ(QAOSTYPE)_"^"_QAOSTYPE
SET QAOSSEQ(QAOSTYPE)=QAOSSEQ(QAOSTYPE)+1
+6 QUIT
LOOP1 ;
+1 SET QAOSZERO=$GET(^QA(741,QAOSD0,0))
if QAOSZERO=""!($PIECE(QAOSZERO,"^",11)=2)
QUIT
+2 SET QAOSSCRN=+$GET(^QA(741,QAOSD0,"SCRN"))
if QAOSSCRN'>0
QUIT
SET QAOSSCRN(0)=+$GET(^QA(741.1,QAOSSCRN,0))
if QAOSSCRN(0)'>0
QUIT
+3 SET QAOSD1=+$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
SET QAOSFIND=$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
if QAOSFIND=QAOSEXCP
QUIT
+4 SET QAOS=$GET(^UTILITY($JOB,"QAOSXREF",QAOSSCRN(0)))
SET QAOSSEQ=+QAOS
SET QAOSTYPE=$PIECE(QAOS,"^",2)
if QAOSLIST'[("^"_QAOSTYPE_"^")
QUIT
+5 SET QAOSHIEN=+$PIECE(QAOSZERO,"^",5)
+6 SET QAOSHIEN(0)=$GET(^SC(QAOSHIEN,0))
+7 IF $PIECE(QAOSHIEN(0),"^",3)="C"
Begin DoDot:1
+8 SET QAOSSERV(0)=$PIECE(QAOSHIEN(0),"^",8)
+9 if QAOSSERV(0)="N"
SET QAOSSERV(0)="NE"
+10 if QAOSSERV(0)="0"
SET QAOSSERV(0)="~"
+11 QUIT
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET QAOSWIEN=+$GET(^SC(QAOSHIEN,42))
+14 SET QAOSSERV(0)=$PIECE($GET(^DIC(42,QAOSWIEN,0)),"^",3)
+15 QUIT
End DoDot:1
+16 if QAOSSERV(0)=""
SET QAOSSERV(0)="~"
+17 SET QAOSSERV=$SELECT($DATA(QAOSSERV(QAOSSERV(0)))#2:$PIECE(QAOSSERV(QAOSSERV(0)),"^"),1:"~UNKNOWN")
+18 if QAOSSORT="S"
DO SERVICE
if QAOSSORT="C"
DO CRITERIA
+19 QUIT
SERVICE ;
+1 SET QAOSTEMP=^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSERV,QAOSSEQ)
SET $PIECE(QAOSTEMP,"^",2)=$PIECE(QAOSTEMP,"^",2)+1
SET ^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSERV,QAOSSEQ)=QAOSTEMP
+2 QUIT
CRITERIA ;
+1 SET QAOPIECE=$PIECE(QAOSSERV(QAOSSERV(0)),"^",2)+1
SET QAOSTEMP=^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSEQ)
SET $PIECE(QAOSTEMP,"^",QAOPIECE)=$PIECE(QAOSTEMP,"^",QAOPIECE)+1
SET ^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSEQ)=QAOSTEMP
+2 SET ^UTILITY($JOB,"QAOQIP",QAOSTYPE,QAOSSEQ,QAOSSERV(0),QAOSD0)=""
+3 QUIT
