- QAOSPSY0 ;HISC/DAD-SYSTEM / EQUIPMENT PROBLEMS ;6/11/93 15:59
- ;;3.0;Occurrence Screen;;09/14/1993
- D ^QAQDATE G:QAQQUIT EXIT
- K %ZIS S %ZIS="QM" D ^%ZIS G:POP EXIT I $D(IO("Q")) S ZTDESC="System/equipment problems report",ZTRTN="ENTSK^QAOSPSY0",ZTSAVE("QAOS*")="",ZTSAVE("QAQ*")="" D ^%ZTLOAD G EXIT
- ENTSK ;
- K ^TMP($J,"QAOSPSY"),UNDL S $P(UNDL,"-",80)="-" S QAOSQUIT=0,PAGE=1,Y=DT X ^DD("DD") S TODAY=$P(Y,"@")
- F QAOSDT=QAQNBEG-.0000001:0 S QAOSDT=$O(^QA(741,"C",QAOSDT)) Q:(QAOSDT'>0)!(QAOSDT>QAQNEND) F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDT,QAOSD0)) Q:QAOSD0'>0 D LOOP1
- U IO D HEAD I '$D(^TMP($J,"QAOSPSY")) W !!,"NO DATA FOUND FOR THIS REPORT" G EXIT
- S SERV="" F SRV=0:0 S SERV=$O(^TMP($J,"QAOSPSY",SERV)) Q:SERV=""!QAOSQUIT D SUBHEAD S PAT="" F PT=0:0 S PAT=$O(^TMP($J,"QAOSPSY",SERV,PAT)) Q:PAT=""!QAOSQUIT F SCRN=0:0 S SCRN=$O(^TMP($J,"QAOSPSY",SERV,PAT,SCRN)) Q:SCRN'>0!QAOSQUIT D PRT1
- EXIT ;
- W ! D ^%ZISC
- K %ZIS,CONFIRM,LOC,PAGE,PAT,PATIENT,PT,POP,QAOSD0,QAOSDT,QAOSQUIT,QAOSZERO,SCREEN,SCRN,SERV,SERVICE,SRV,SSN,STATUS,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT,D,I,Y,Z,QA,QAOSD1,^TMP($J,"QAOSPSY")
- D K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"
- Q
- LOOP1 ;
- S QAOSZERO=^QA(741,QAOSD0,0),SCRN=+$G(^("SCRN")),STATUS=$P(QAOSZERO,"^",11) Q:STATUS=2 S STATUS=$S(+STATUS=0:" OPEN",1:"CLOSED")
- K CONFIRM F QA=1:1:4 S CONFIRM(QA)=0
- F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE",QAOSD1)) Q:QAOSD1'>0 D
- . S CONFIRM=+$P($G(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",5)
- . Q:CONFIRM=4 S CONFIRM(CONFIRM)=1
- . Q
- S CONFIRM=$S(CONFIRM(3)!(CONFIRM(1)&CONFIRM(2)):"SYSTEM & EQUIP",CONFIRM(1):"EQUIPMENT",CONFIRM(2):"SYSTEM",1:"") Q:CONFIRM=""
- S LOC=$G(^QA(741.1,SCRN,0)),SCREEN=$P(LOC,"^",2),SCRN=$S(LOC]"":+LOC,1:SCRN)
- S SERVICE=$P(QAOSZERO,"^",6),SERVICE=$S(SERVICE'>0:"~UNKNOWN",$D(^DIC(49,SERVICE,0))#2:$P(^(0),"^"),1:"~UNKNOWN")
- S LOC=$G(^DPT(+QAOSZERO,0)),PATIENT=$S(LOC]"":$P(LOC,"^"),1:+QAOSZERO),SSN=$P(LOC,"^",9)
- S ^TMP($J,"QAOSPSY",SERVICE,PATIENT,SCRN,QAOSDT)=SSN_"^"_STATUS_"^"_CONFIRM_"^"_SCREEN
- Q
- PRT1 ;
- F QAOSDT=0:0 S QAOSDT=$O(^TMP($J,"QAOSPSY",SERV,PAT,SCRN,QAOSDT)) Q:QAOSDT'>0!QAOSQUIT D PRT2
- Q
- PRT2 ;
- S LOC=^TMP($J,"QAOSPSY",SERV,PAT,SCRN,QAOSDT),SSN=+LOC,STATUS=$P(LOC,"^",2),CONFIRM=$P(LOC,"^",3),SCREEN=$P(LOC,"^",4),Y=QAOSDT\1 X ^DD("DD")
- W !!,PAT,?32,SSN,?43,Y,?56,STATUS,?64,CONFIRM,!?1,SCRN,?8,$E(SCREEN,1,72)
- I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD,SUBHEAD:($O(^TMP($J,"QAOSPSY",SERV,PAT))]"")!($O(^TMP($J,"QAOSPSY",SERV,PAT,SCRN))]"")!($O(^TMP($J,"QAOSPSY",SERV,PAT,SCRN,QAOSDT))]"")
- Q
- HEAD ;
- W:(PAGE>1)!($E(IOST)="C") @IOF
- W !!?26,"SYSTEM / EQUIPMENT PROBLEMS",?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE S PAGE=PAGE+1 D EN6^QAQAUTL
- W !,"PATIENT / SCREEN",?32,"SSN",?43,"DATE",?56,"STATUS",?64,"CONFIRMED ISSUE",!,UNDL
- Q
- SUBHEAD ;
- W !!?3,"SERVICE: ",$S(SERV["~":$P(SERV,"~",2),1:SERV)
- Q
- PAUSE ;
- K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPSY0 2966 printed Mar 13, 2025@21:27:01 Page 2
- QAOSPSY0 ;HISC/DAD-SYSTEM / EQUIPMENT PROBLEMS ;6/11/93 15:59
- +1 ;;3.0;Occurrence Screen;;09/14/1993
- +2 DO ^QAQDATE
- if QAQQUIT
- GOTO EXIT
- +3 KILL %ZIS
- SET %ZIS="QM"
- DO ^%ZIS
- if POP
- GOTO EXIT
- IF $DATA(IO("Q"))
- SET ZTDESC="System/equipment problems report"
- SET ZTRTN="ENTSK^QAOSPSY0"
- SET ZTSAVE("QAOS*")=""
- SET ZTSAVE("QAQ*")=""
- DO ^%ZTLOAD
- GOTO EXIT
- ENTSK ;
- +1 KILL ^TMP($JOB,"QAOSPSY"),UNDL
- SET $PIECE(UNDL,"-",80)="-"
- SET QAOSQUIT=0
- SET PAGE=1
- SET Y=DT
- XECUTE ^DD("DD")
- SET TODAY=$PIECE(Y,"@")
- +2 FOR QAOSDT=QAQNBEG-.0000001:0
- SET QAOSDT=$ORDER(^QA(741,"C",QAOSDT))
- if (QAOSDT'>0)!(QAOSDT>QAQNEND)
- QUIT
- FOR QAOSD0=0:0
- SET QAOSD0=$ORDER(^QA(741,"C",QAOSDT,QAOSD0))
- if QAOSD0'>0
- QUIT
- DO LOOP1
- +3 USE IO
- DO HEAD
- IF '$DATA(^TMP($JOB,"QAOSPSY"))
- WRITE !!,"NO DATA FOUND FOR THIS REPORT"
- GOTO EXIT
- +4 SET SERV=""
- FOR SRV=0:0
- SET SERV=$ORDER(^TMP($JOB,"QAOSPSY",SERV))
- if SERV=""!QAOSQUIT
- QUIT
- DO SUBHEAD
- SET PAT=""
- FOR PT=0:0
- SET PAT=$ORDER(^TMP($JOB,"QAOSPSY",SERV,PAT))
- if PAT=""!QAOSQUIT
- QUIT
- FOR SCRN=0:0
- SET SCRN=$ORDER(^TMP($JOB,"QAOSPSY",SERV,PAT,SCRN))
- if SCRN'>0!QAOSQUIT
- QUIT
- DO PRT1
- EXIT ;
- +1 WRITE !
- DO ^%ZISC
- +2 KILL %ZIS,CONFIRM,LOC,PAGE,PAT,PATIENT,PT,POP,QAOSD0,QAOSDT,QAOSQUIT,QAOSZERO,SCREEN,SCRN,SERV,SERVICE,SRV,SSN,STATUS,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT,D,I,Y,Z,QA,QAOSD1,^TMP($JOB,"QAOSPSY")
- +3 DO K^QAQDATE
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 QUIT
- LOOP1 ;
- +1 SET QAOSZERO=^QA(741,QAOSD0,0)
- SET SCRN=+$GET(^("SCRN"))
- SET STATUS=$PIECE(QAOSZERO,"^",11)
- if STATUS=2
- QUIT
- SET STATUS=$SELECT(+STATUS=0:" OPEN",1:"CLOSED")
- +2 KILL CONFIRM
- FOR QA=1:1:4
- SET CONFIRM(QA)=0
- +3 FOR QAOSD1=0:0
- SET QAOSD1=$ORDER(^QA(741,QAOSD0,"CMTE",QAOSD1))
- if QAOSD1'>0
- QUIT
- Begin DoDot:1
- +4 SET CONFIRM=+$PIECE($GET(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),"^",5)
- +5 if CONFIRM=4
- QUIT
- SET CONFIRM(CONFIRM)=1
- +6 QUIT
- End DoDot:1
- +7 SET CONFIRM=$SELECT(CONFIRM(3)!(CONFIRM(1)&CONFIRM(2)):"SYSTEM & EQUIP",CONFIRM(1):"EQUIPMENT",CONFIRM(2):"SYSTEM",1:"")
- if CONFIRM=""
- QUIT
- +8 SET LOC=$GET(^QA(741.1,SCRN,0))
- SET SCREEN=$PIECE(LOC,"^",2)
- SET SCRN=$SELECT(LOC]"":+LOC,1:SCRN)
- +9 SET SERVICE=$PIECE(QAOSZERO,"^",6)
- SET SERVICE=$SELECT(SERVICE'>0:"~UNKNOWN",$DATA(^DIC(49,SERVICE,0))#2:$PIECE(^(0),"^"),1:"~UNKNOWN")
- +10 SET LOC=$GET(^DPT(+QAOSZERO,0))
- SET PATIENT=$SELECT(LOC]"":$PIECE(LOC,"^"),1:+QAOSZERO)
- SET SSN=$PIECE(LOC,"^",9)
- +11 SET ^TMP($JOB,"QAOSPSY",SERVICE,PATIENT,SCRN,QAOSDT)=SSN_"^"_STATUS_"^"_CONFIRM_"^"_SCREEN
- +12 QUIT
- PRT1 ;
- +1 FOR QAOSDT=0:0
- SET QAOSDT=$ORDER(^TMP($JOB,"QAOSPSY",SERV,PAT,SCRN,QAOSDT))
- if QAOSDT'>0!QAOSQUIT
- QUIT
- DO PRT2
- +2 QUIT
- PRT2 ;
- +1 SET LOC=^TMP($JOB,"QAOSPSY",SERV,PAT,SCRN,QAOSDT)
- SET SSN=+LOC
- SET STATUS=$PIECE(LOC,"^",2)
- SET CONFIRM=$PIECE(LOC,"^",3)
- SET SCREEN=$PIECE(LOC,"^",4)
- SET Y=QAOSDT\1
- XECUTE ^DD("DD")
- +2 WRITE !!,PAT,?32,SSN,?43,Y,?56,STATUS,?64,CONFIRM,!?1,SCRN,?8,$EXTRACT(SCREEN,1,72)
- +3 IF $Y>(IOSL-6)
- if $EXTRACT(IOST)="C"
- DO PAUSE
- if QAOSQUIT
- QUIT
- DO HEAD
- if ($ORDER(^TMP($JOB,"QAOSPSY",SERV,PAT))]"")!($ORDER(^TMP($JOB,"QAOSPSY",SERV,PAT,SCRN))]"")!($ORDER(^TMP($JOB,"QAOSPSY",SERV,PAT,SCRN,QAOSDT))]"")
- DO SUBHEAD
- +4 QUIT
- HEAD ;
- +1 if (PAGE>1)!($EXTRACT(IOST)="C")
- WRITE @IOF
- +2 WRITE !!?26,"SYSTEM / EQUIPMENT PROBLEMS",?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE
- SET PAGE=PAGE+1
- DO EN6^QAQAUTL
- +3 WRITE !,"PATIENT / SCREEN",?32,"SSN",?43,"DATE",?56,"STATUS",?64,"CONFIRMED ISSUE",!,UNDL
- +4 QUIT
- SUBHEAD ;
- +1 WRITE !!?3,"SERVICE: ",$SELECT(SERV["~":$PIECE(SERV,"~",2),1:SERV)
- +2 QUIT
- PAUSE ;
- +1 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
- +2 QUIT
