- QAOSPSS2 ;HISC/DAD-OCCURRENCE SERVICE STATISTICS BY CRITERIA ;9/14/92 10:58
- ;;3.0;Occurrence Screen;;09/14/1993
- S QAOSQUIT=0,QAOSPAGE=1,X="T",%DT="" D ^%DT X ^DD("DD") S TODAY=Y K UNDL S $P(UNDL,"-",81)=""
- F QAOSTYPE="N","L","1" Q:QAOSQUIT I $O(^UTILITY($J,"QAOSPSS",QAOSTYPE,0)) S COLTOT="0^0^0^0^0^0^0^0^0^0^0^0^0" D HEAD F QAOSSEQ=0:0 S QAOSSEQ=$O(^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ)) Q:QAOSSEQ'>0!QAOSQUIT D LOOP1
- Q
- LOOP1 ;
- S TAB=15,ROWTOT=0,QAOSTEMP=^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ) W !!,$J(QAOSSEQ,3),?6,$P(QAOSTEMP,"^")
- F QA=2:1:$L(QAOSTEMP,"^") S X=$P(QAOSTEMP,"^",QA),ROWTOT=ROWTOT+X W ?TAB,$J(X,3) S TAB=TAB+5,$P(COLTOT,"^",QA-1)=$P(COLTOT,"^",QA-1)+X
- W ?TAB,$J(ROWTOT,5) S $P(COLTOT,"^",13)=$P(COLTOT,"^",13)+ROWTOT
- S FLG=$O(^UTILITY($J,"QAOSPSS",QAOSTYPE,QAOSSEQ))
- I FLG'>0 D COLTOT,PAUSE:$E(IOST)="C" Q
- I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D:FLG HEAD
- Q
- COLTOT ;
- W !!,UNDL,!,"TOTAL" S TAB=14 F QA=1:1:$L(COLTOT,"^")-1 S X=$P(COLTOT,"^",QA) W ?TAB,$J(X,4) S TAB=TAB+5
- W ?75,$J($P(COLTOT,"^",13),5)
- Q
- PAUSE ;
- K DIR S DIR(0)="E" D ^DIR S QAOSQUIT=$S(Y'>0:1,1:0)
- Q
- HEAD ;
- W:(QAOSPAGE>1)!($E(IOST)="C") @IOF
- W !!?22,"OCCURRENCE SCREEN SERVICE STATISTICS",?68,TODAY
- W !?QAQTART,QAQ2HED,?68,"PAGE: ",QAOSPAGE S QAOSPAGE=QAOSPAGE+1
- W !!,"CRITERIA",?14,"BLIND",?21,"DOM",?28,"MEDICINE",?40,"NHCU",?45,"NON",?50,"PSYCH",?61,"SCI",?69,"UNKNOWN"
- W !?3,"SCREEN",?14,"REHAB",?23,"INTERMED",?33,"NEUROLOGY",?45,"COUNT",?53,"REHAB-MED",?64,"SURGERY",?75,"TOTAL",!,UNDL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPSS2 1540 printed Jan 18, 2025@03:23:14 Page 2
- QAOSPSS2 ;HISC/DAD-OCCURRENCE SERVICE STATISTICS BY CRITERIA ;9/14/92 10:58
- +1 ;;3.0;Occurrence Screen;;09/14/1993
- +2 SET QAOSQUIT=0
- SET QAOSPAGE=1
- SET X="T"
- SET %DT=""
- DO ^%DT
- XECUTE ^DD("DD")
- SET TODAY=Y
- KILL UNDL
- SET $PIECE(UNDL,"-",81)=""
- +3 FOR QAOSTYPE="N","L","1"
- if QAOSQUIT
- QUIT
- IF $ORDER(^UTILITY($JOB,"QAOSPSS",QAOSTYPE,0))
- SET COLTOT="0^0^0^0^0^0^0^0^0^0^0^0^0"
- DO HEAD
- FOR QAOSSEQ=0:0
- SET QAOSSEQ=$ORDER(^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSEQ))
- if QAOSSEQ'>0!QAOSQUIT
- QUIT
- DO LOOP1
- +4 QUIT
- LOOP1 ;
- +1 SET TAB=15
- SET ROWTOT=0
- SET QAOSTEMP=^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSEQ)
- WRITE !!,$JUSTIFY(QAOSSEQ,3),?6,$PIECE(QAOSTEMP,"^")
- +2 FOR QA=2:1:$LENGTH(QAOSTEMP,"^")
- SET X=$PIECE(QAOSTEMP,"^",QA)
- SET ROWTOT=ROWTOT+X
- WRITE ?TAB,$JUSTIFY(X,3)
- SET TAB=TAB+5
- SET $PIECE(COLTOT,"^",QA-1)=$PIECE(COLTOT,"^",QA-1)+X
- +3 WRITE ?TAB,$JUSTIFY(ROWTOT,5)
- SET $PIECE(COLTOT,"^",13)=$PIECE(COLTOT,"^",13)+ROWTOT
- +4 SET FLG=$ORDER(^UTILITY($JOB,"QAOSPSS",QAOSTYPE,QAOSSEQ))
- +5 IF FLG'>0
- DO COLTOT
- if $EXTRACT(IOST)="C"
- DO PAUSE
- QUIT
- +6 IF $Y>(IOSL-6)
- if $EXTRACT(IOST)="C"
- DO PAUSE
- if QAOSQUIT
- QUIT
- if FLG
- DO HEAD
- +7 QUIT
- COLTOT ;
- +1 WRITE !!,UNDL,!,"TOTAL"
- SET TAB=14
- FOR QA=1:1:$LENGTH(COLTOT,"^")-1
- SET X=$PIECE(COLTOT,"^",QA)
- WRITE ?TAB,$JUSTIFY(X,4)
- SET TAB=TAB+5
- +2 WRITE ?75,$JUSTIFY($PIECE(COLTOT,"^",13),5)
- +3 QUIT
- PAUSE ;
- +1 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
- +2 QUIT
- HEAD ;
- +1 if (QAOSPAGE>1)!($EXTRACT(IOST)="C")
- WRITE @IOF
- +2 WRITE !!?22,"OCCURRENCE SCREEN SERVICE STATISTICS",?68,TODAY
- +3 WRITE !?QAQTART,QAQ2HED,?68,"PAGE: ",QAOSPAGE
- SET QAOSPAGE=QAOSPAGE+1
- +4 WRITE !!,"CRITERIA",?14,"BLIND",?21,"DOM",?28,"MEDICINE",?40,"NHCU",?45,"NON",?50,"PSYCH",?61,"SCI",?69,"UNKNOWN"
- +5 WRITE !?3,"SCREEN",?14,"REHAB",?23,"INTERMED",?33,"NEUROLOGY",?45,"COUNT",?53,"REHAB-MED",?64,"SURGERY",?75,"TOTAL",!,UNDL
- +6 QUIT