- QAOSPTR0 ;HISC/DAD-REVIEW LEVEL TRACKING REPORT ;10/19/92 15:24
- ;;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="Review level tracking report",ZTRTN="ENTSK^QAOSPTR0",ZTSAVE("QAQ*")="" D ^%ZTLOAD G EXIT
- ENTSK ;
- S QAOSCLIN=$O(^QA(741.2,"C",1,0)),QAOSPEER=$O(^QA(741.2,"C",2,0)),QAOSMGMT=$O(^QA(741.2,"C",3,0)),QAOSCMTE=$O(^QA(741.2,"C",4,0)) K ^TMP($J,"QAOSPTR")
- F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"AD",0,QAOSD0)) Q:QAOSD0'>0 D:$D(^QA(741,QAOSD0,"REVR","B",QAOSCLIN)) LOOP1
- U IO D ^QAOSPTR1
- EXIT ;
- W ! D ^%ZISC
- K %ZIS,ACTION,COUNT,DATE,FIND,HEAD2,LEVEL,LOC,PAGE,PAT,POP,PT,QAOSCLIN,QAOSCMTE,QAOSD0,QAOSD1,QAOSD2,QAOSDT,QAOSMGMT,QAOSPEER,QAOSQUIT,QAOSREVR,QAOSRVW,QAOSZERO,REVR,SCRN,SERV,SRV,SSN,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,^TMP($J,"QAOSPTR")
- K %DT,D,DI,DIC,DQ,I,TYPE,Y,Z D K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"
- Q
- LOOP1 ;
- S QAOSQUIT=0,QAOSZERO=^QA(741,QAOSD0,0),SCRN=+$G(^("SCRN")),PAT=$S($D(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO),SSN=$P(PAT,"^",9),PAT=$P(PAT,"^"),SCRN=$S($D(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN)
- S SERV=$P(QAOSZERO,"^",6),SERV=$S(SERV="":"~UNKNOWN",$D(^DIC(49,SERV,0))#2:$P(^(0),"^"),1:"~UNKNOWN"),DATE=$P(QAOSZERO,"^",3)
- Q:(DATE<QAQNBEG)!(DATE>QAQNEND)
- S ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE)=SSN
- F QAOSREVR=QAOSCLIN,QAOSPEER,QAOSMGMT Q:QAOSQUIT S COUNT=1 I $D(^QA(741,QAOSD0,"REVR","B",QAOSREVR)) F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSREVR,QAOSD1)) Q:QAOSD1'>0!QAOSQUIT D REVRLOOP
- Q:QAOSQUIT S COUNT=1 F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"CMTE",QAOSD1)) Q:QAOSD1'>0 D CMTELOOP
- Q
- REVRLOOP ;
- S QAOSRVW=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),FIND=$P(QAOSRVW,"^",5),FIND=$S(FIND'>0:"",$D(^QA(741.6,FIND,0))#2:$P(^(0),"^",2),1:"")
- I FIND="",QAOSREVR=QAOSCLIN K ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE) S QAOSQUIT=1 Q
- S QAOSD2=$O(^QA(741,QAOSD0,"REVR",QAOSD1,2,0)),ACTION=$S(QAOSD2'>0:"",$D(^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2,0))#2:+^(0),1:""),ACTION=$S(ACTION'>0:"",$D(^QA(741.7,ACTION,0))#2:$P(^(0),"^",3),1:"")
- S X=$S(QAOSREVR=QAOSMGMT:ACTION,1:FIND) S:X]"" ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSREVR,COUNT)=X,COUNT=COUNT+1
- Q
- CMTELOOP ;
- S QAOSRVW=$G(^QA(741,QAOSD0,"CMTE",QAOSD1,0)),FIND=$P(QAOSRVW,"^",2),FIND=$S(FIND'>0:"",$D(^QA(741.6,FIND,0))#2:$P(^(0),"^",2),1:"")
- S:FIND]"" ^TMP($J,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSCMTE,COUNT)=FIND,COUNT=COUNT+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPTR0 2418 printed Mar 13, 2025@21:27:02 Page 2
- QAOSPTR0 ;HISC/DAD-REVIEW LEVEL TRACKING REPORT ;10/19/92 15:24
- +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="Review level tracking report"
- SET ZTRTN="ENTSK^QAOSPTR0"
- SET ZTSAVE("QAQ*")=""
- DO ^%ZTLOAD
- GOTO EXIT
- ENTSK ;
- +1 SET QAOSCLIN=$ORDER(^QA(741.2,"C",1,0))
- SET QAOSPEER=$ORDER(^QA(741.2,"C",2,0))
- SET QAOSMGMT=$ORDER(^QA(741.2,"C",3,0))
- SET QAOSCMTE=$ORDER(^QA(741.2,"C",4,0))
- KILL ^TMP($JOB,"QAOSPTR")
- +2 FOR QAOSD0=0:0
- SET QAOSD0=$ORDER(^QA(741,"AD",0,QAOSD0))
- if QAOSD0'>0
- QUIT
- if $DATA(^QA(741,QAOSD0,"REVR","B",QAOSCLIN))
- DO LOOP1
- +3 USE IO
- DO ^QAOSPTR1
- EXIT ;
- +1 WRITE !
- DO ^%ZISC
- +2 KILL %ZIS,ACTION,COUNT,DATE,FIND,HEAD2,LEVEL,LOC,PAGE,PAT,POP,PT,QAOSCLIN,QAOSCMTE,QAOSD0,QAOSD1,QAOSD2,QAOSDT,QAOSMGMT,QAOSPEER,QAOSQUIT,QAOSREVR,QAOSRVW,QAOSZERO,REVR,SCRN,SERV,SRV,SSN,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,^TMP($JOB,"QAOSPTR")
- +3 KILL %DT,D,DI,DIC,DQ,I,TYPE,Y,Z
- DO K^QAQDATE
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 QUIT
- LOOP1 ;
- +1 SET QAOSQUIT=0
- SET QAOSZERO=^QA(741,QAOSD0,0)
- SET SCRN=+$GET(^("SCRN"))
- SET PAT=$SELECT($DATA(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO)
- SET SSN=$PIECE(PAT,"^",9)
- SET PAT=$PIECE(PAT,"^")
- SET SCRN=$SELECT($DATA(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN)
- +2 SET SERV=$PIECE(QAOSZERO,"^",6)
- SET SERV=$SELECT(SERV="":"~UNKNOWN",$DATA(^DIC(49,SERV,0))#2:$PIECE(^(0),"^"),1:"~UNKNOWN")
- SET DATE=$PIECE(QAOSZERO,"^",3)
- +3 if (DATE<QAQNBEG)!(DATE>QAQNEND)
- QUIT
- +4 SET ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE)=SSN
- +5 FOR QAOSREVR=QAOSCLIN,QAOSPEER,QAOSMGMT
- if QAOSQUIT
- QUIT
- SET COUNT=1
- IF $DATA(^QA(741,QAOSD0,"REVR","B",QAOSREVR))
- FOR QAOSD1=0:0
- SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSREVR,QAOSD1))
- if QAOSD1'>0!QAOSQUIT
- QUIT
- DO REVRLOOP
- +6 if QAOSQUIT
- QUIT
- SET COUNT=1
- FOR QAOSD1=0:0
- SET QAOSD1=$ORDER(^QA(741,QAOSD0,"CMTE",QAOSD1))
- if QAOSD1'>0
- QUIT
- DO CMTELOOP
- +7 QUIT
- REVRLOOP ;
- +1 SET QAOSRVW=$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
- SET FIND=$PIECE(QAOSRVW,"^",5)
- SET FIND=$SELECT(FIND'>0:"",$DATA(^QA(741.6,FIND,0))#2:$PIECE(^(0),"^",2),1:"")
- +2 IF FIND=""
- IF QAOSREVR=QAOSCLIN
- KILL ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE)
- SET QAOSQUIT=1
- QUIT
- +3 SET QAOSD2=$ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,2,0))
- SET ACTION=$SELECT(QAOSD2'>0:"",$DATA(^QA(741,QAOSD0,"REVR",QAOSD1,2,QAOSD2,0))#2:+^(0),1:"")
- SET ACTION=$SELECT(ACTION'>0:"",$DATA(^QA(741.7,ACTION,0))#2:$PIECE(^(0),"^",3),1:"")
- +4 SET X=$SELECT(QAOSREVR=QAOSMGMT:ACTION,1:FIND)
- if X]""
- SET ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSREVR,COUNT)=X
- SET COUNT=COUNT+1
- +5 QUIT
- CMTELOOP ;
- +1 SET QAOSRVW=$GET(^QA(741,QAOSD0,"CMTE",QAOSD1,0))
- SET FIND=$PIECE(QAOSRVW,"^",2)
- SET FIND=$SELECT(FIND'>0:"",$DATA(^QA(741.6,FIND,0))#2:$PIECE(^(0),"^",2),1:"")
- +2 if FIND]""
- SET ^TMP($JOB,"QAOSPTR",SERV,SCRN,PAT,DATE,QAOSCMTE,COUNT)=FIND
- SET COUNT=COUNT+1
- +3 QUIT
