QAOSPCL0 ;HISC/DAD-CLINICAL REVIEWER WORKSHEET (PART 1) ;2/12/93 15:16
;;3.0;Occurrence Screen;;09/14/1993
I $D(^QA(740,1,"OS"))#2 Q:+$P(^("OS"),"^",3)=0
Q:$D(^QA(741,QAOSD0,0))[0 Q:$D(^("SCRN"))[0
S QAOSZERO=^QA(741,QAOSD0,0),(QAOSSCRN,SCRN)=+$G(^("SCRN")),QAOSQUIT=0,PAGE=1,HEADER=1,Y=DT X ^DD("DD") S TODAY=Y K UNDL S $P(UNDL,"=",80)="=" S SCRN=$G(^QA(741.1,SCRN,0)) Q:SCRN=""
S QAOSCLIN=$O(^QA(741.2,"C",1,0)),QAOSD1=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0)),QAOSMULT=$S(QAOSD1'>0:"",$D(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2:^(0),1:"")
S:QAOSDATA=1 QAOSMULT="" S:(QAOSDATA=2)&('$D(^QA(741,QAOSD0,"REVR","B",QAOSCLIN))) QAOSMULT="" S QAOSPRIM=$P(QAOSMULT,"^",4)
G:$O(^QA(741.4,"AC",QAOSSCRN,""))="" EXIT D HEAD
F QAOSCODE=0:0 S QAOSCODE=$O(^QA(741.4,"AC",QAOSSCRN,QAOSCODE)) Q:QAOSCODE'>0!QAOSQUIT F QAOSS0=0:0 S QAOSS0=$O(^QA(741.4,"AC",QAOSSCRN,QAOSCODE,QAOSS0)) Q:QAOSS0'>0!QAOSQUIT D LOOP1
G:QAOSQUIT DONE S QAOSHEAD="COMMENTS" W !!,QAOSHEAD S DIWL=4,DIWR=75,DIWF="" K ^UTILITY($J,"W")
I QAOSHOW'=3,QAOSDATA=2 F QAOSS0=0:0 S QAOSS0=$O(^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSS0)) Q:QAOSS0'>0 S X=^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSS0,0) D ^DIWP
F QA=0:0 S QA=$O(^UTILITY($J,"W",DIWL,QA)) Q:QA'>0!QAOSQUIT W !?3,^UTILITY($J,"W",DIWL,QA,0) I $Y>(IOSL-6),$O(^UTILITY($J,"W",DIWL,QA)) D:$E(IOST)="C" PAUSE I 'QAOSQUIT S HEADER=0 D HEAD W !!,QAOSHEAD
DONE D:$E(IOST)="C" PAUSE:'QAOSQUIT W:$E(IOST)'="C" @IOF
EXIT ;
K DIWF,DIWL,DIWR,FLAG,HEADER,LOC,NAME,PAGE,QA,QAOSCLIN,QAOSCODE,QAOSMULT,QAOSNUM,QAOSPRIM,QAOSS0,QAOSSCRN,QAOSWHEN,QAOSZERO,SCREEN,SCRN,SSN,TEXT,TODAY,UNDL,WARD,X,Y
Q
LOOP1 ;
S QAOSNUM=$P(^QA(741.4,QAOSS0,0),"^",1),X=$P($G(^(1)),"^",1),DIWF="",DIWL=15,DIWR=79
K ^UTILITY($J,"W") D ^DIWP I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT S HEADER=0 D HEAD
W !!,$J(QAOSNUM,3),$S(QAOSS0=QAOSPRIM:" (Y)/ N",1:" Y / N")
S FLAG=0 F QA=0:0 S QA=$O(^UTILITY($J,"W",DIWL,QA)) Q:QA'>0 W:FLAG ! W ?15,^UTILITY($J,"W",DIWL,QA,0) S FLAG=1
Q
HEAD ;
W:(PAGE>1)!($E(IOST)="C") @IOF
W !!?23,"CLINICAL REVIEW WORKSHEET (PART 1)",?68,TODAY,!?68,"PAGE: ",PAGE S PAGE=PAGE+1 D EN6^QAQAUTL
S LOC=$S($D(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO),NAME=$P(LOC,"^"),SSN=$P(LOC,"^",9),Y=$P(QAOSZERO,"^",3)\1 X ^DD("DD") S QAOSWHEN=Y,SCREEN=+SCRN,TEXT=$P(SCRN,"^",2)
S WARD=$S($D(^DPT(+QAOSZERO,.1))#2:$E(^(.1),1,22),1:"UNKNOWN"),WARD(0)=$P(QAOSZERO,"^",5),WARD(0)=$S(WARD(0)'>0:"______________________",$D(^SC(WARD(0),0))#2:$E($P(^(0),"^"),1,22),1:"______________________")
W !,"PATIENT: ",NAME,?39,"SSN: ",SSN,?56,"OCCURRENCE: ",QAOSWHEN,!,"WARD/CLINIC- CURRENT: ",WARD,?46,"OCCURRENCE: ",WARD(0),!,SCREEN,?8,$E(TEXT,1,72) G:'HEADER INSTR
S QA=$P(QAOSMULT,"^",2) W !!,"CLINICAL REVIEWER: ",$S(QA'>0:"________________________________",$D(^VA(200,QA,0))#2:$P(^(0),"^"),1:"________________________________"),?52,"REVIEW DATE: ______________"
S LOC=^QA(741,QAOSD0,0),QA=$P(LOC,"^",10) W !!,"RESIDENT/PROVIDER: ",$S(QA'>0:"________________________",$D(^VA(200,QA,0))#2:$E($P(^(0),"^"),1,24),1:"________________________")
S QA=$P(LOC,"^",9) W ?44,"ATTENDING: ",$S(QA'>0:"_________________________",$D(^VA(200,QA,0))#2:$E($P(^(0),"^"),1,25),1:"_________________________")
S QA=$P(LOC,"^",7) W !!,"TREATING SPECIALTY: ",$S(QA'>0:"_______________________________",$D(^DIC(45.7,QA,0))#2:$P(^(0),"^"),1:"_______________________________")
INSTR W !!,"Instructions: Review the medical record and answer the following by circling",!,"the appropriate 'Y' or 'N'. Record any comments at the end of the worksheet.",!,UNDL
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[HQAOSPCL0 3630 printed Dec 13, 2024@02:21:38 Page 2
QAOSPCL0 ;HISC/DAD-CLINICAL REVIEWER WORKSHEET (PART 1) ;2/12/93 15:16
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 IF $DATA(^QA(740,1,"OS"))#2
if +$PIECE(^("OS"),"^",3)=0
QUIT
+3 if $DATA(^QA(741,QAOSD0,0))[0
QUIT
if $DATA(^("SCRN"))[0
QUIT
+4 SET QAOSZERO=^QA(741,QAOSD0,0)
SET (QAOSSCRN,SCRN)=+$GET(^("SCRN"))
SET QAOSQUIT=0
SET PAGE=1
SET HEADER=1
SET Y=DT
XECUTE ^DD("DD")
SET TODAY=Y
KILL UNDL
SET $PIECE(UNDL,"=",80)="="
SET SCRN=$GET(^QA(741.1,SCRN,0))
if SCRN=""
QUIT
+5 SET QAOSCLIN=$ORDER(^QA(741.2,"C",1,0))
SET QAOSD1=+$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
SET QAOSMULT=$SELECT(QAOSD1'>0:"",$DATA(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2:^(0),1:"")
+6 if QAOSDATA=1
SET QAOSMULT=""
if (QAOSDATA=2)&('$DATA(^QA(741,QAOSD0,"REVR","B",QAOSCLIN)))
SET QAOSMULT=""
SET QAOSPRIM=$PIECE(QAOSMULT,"^",4)
+7 if $ORDER(^QA(741.4,"AC",QAOSSCRN,""))=""
GOTO EXIT
DO HEAD
+8 FOR QAOSCODE=0:0
SET QAOSCODE=$ORDER(^QA(741.4,"AC",QAOSSCRN,QAOSCODE))
if QAOSCODE'>0!QAOSQUIT
QUIT
FOR QAOSS0=0:0
SET QAOSS0=$ORDER(^QA(741.4,"AC",QAOSSCRN,QAOSCODE,QAOSS0))
if QAOSS0'>0!QAOSQUIT
QUIT
DO LOOP1
+9 if QAOSQUIT
GOTO DONE
SET QAOSHEAD="COMMENTS"
WRITE !!,QAOSHEAD
SET DIWL=4
SET DIWR=75
SET DIWF=""
KILL ^UTILITY($JOB,"W")
+10 IF QAOSHOW'=3
IF QAOSDATA=2
FOR QAOSS0=0:0
SET QAOSS0=$ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSS0))
if QAOSS0'>0
QUIT
SET X=^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSS0,0)
DO ^DIWP
+11 FOR QA=0:0
SET QA=$ORDER(^UTILITY($JOB,"W",DIWL,QA))
if QA'>0!QAOSQUIT
QUIT
WRITE !?3,^UTILITY($JOB,"W",DIWL,QA,0)
IF $Y>(IOSL-6)
IF $ORDER(^UTILITY($JOB,"W",DIWL,QA))
if $EXTRACT(IOST)="C"
DO PAUSE
IF 'QAOSQUIT
SET HEADER=0
DO HEAD
WRITE !!,QAOSHEAD
DONE if $EXTRACT(IOST)="C"
if 'QAOSQUIT
DO PAUSE
if $EXTRACT(IOST)'="C"
WRITE @IOF
EXIT ;
+1 KILL DIWF,DIWL,DIWR,FLAG,HEADER,LOC,NAME,PAGE,QA,QAOSCLIN,QAOSCODE,QAOSMULT,QAOSNUM,QAOSPRIM,QAOSS0,QAOSSCRN,QAOSWHEN,QAOSZERO,SCREEN,SCRN,SSN,TEXT,TODAY,UNDL,WARD,X,Y
+2 QUIT
LOOP1 ;
+1 SET QAOSNUM=$PIECE(^QA(741.4,QAOSS0,0),"^",1)
SET X=$PIECE($GET(^(1)),"^",1)
SET DIWF=""
SET DIWL=15
SET DIWR=79
+2 KILL ^UTILITY($JOB,"W")
DO ^DIWP
IF $Y>(IOSL-6)
if $EXTRACT(IOST)="C"
DO PAUSE
if QAOSQUIT
QUIT
SET HEADER=0
DO HEAD
+3 WRITE !!,$JUSTIFY(QAOSNUM,3),$SELECT(QAOSS0=QAOSPRIM:" (Y)/ N",1:" Y / N")
+4 SET FLAG=0
FOR QA=0:0
SET QA=$ORDER(^UTILITY($JOB,"W",DIWL,QA))
if QA'>0
QUIT
if FLAG
WRITE !
WRITE ?15,^UTILITY($JOB,"W",DIWL,QA,0)
SET FLAG=1
+5 QUIT
HEAD ;
+1 if (PAGE>1)!($EXTRACT(IOST)="C")
WRITE @IOF
+2 WRITE !!?23,"CLINICAL REVIEW WORKSHEET (PART 1)",?68,TODAY,!?68,"PAGE: ",PAGE
SET PAGE=PAGE+1
DO EN6^QAQAUTL
+3 SET LOC=$SELECT($DATA(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO)
SET NAME=$PIECE(LOC,"^")
SET SSN=$PIECE(LOC,"^",9)
SET Y=$PIECE(QAOSZERO,"^",3)\1
XECUTE ^DD("DD")
SET QAOSWHEN=Y
SET SCREEN=+SCRN
SET TEXT=$PIECE(SCRN,"^",2)
+4 SET WARD=$SELECT($DATA(^DPT(+QAOSZERO,.1))#2:$EXTRACT(^(.1),1,22),1:"UNKNOWN")
SET WARD(0)=$PIECE(QAOSZERO,"^",5)
SET WARD(0)=$SELECT(WARD(0)'>0:"______________________",$DATA(^SC(WARD(0),0))#2:$EXTRACT($PIECE(^(0),"^"),1,22),1:"______________________")
+5 WRITE !,"PATIENT: ",NAME,?39,"SSN: ",SSN,?56,"OCCURRENCE: ",QAOSWHEN,!,"WARD/CLINIC- CURRENT: ",WARD,?46,"OCCURRENCE: ",WARD(0),!,SCREEN,?8,$EXTRACT(TEXT,1,72)
if 'HEADER
GOTO INSTR
+6 SET QA=$PIECE(QAOSMULT,"^",2)
WRITE !!,"CLINICAL REVIEWER: ",$SELECT(QA'>0:"________________________________",$DATA(^VA(200,QA,0))#2:$PIECE(^(0),"^"),1:"________________________________"),?52,"REVIEW DATE: ______________"
+7 SET LOC=^QA(741,QAOSD0,0)
SET QA=$PIECE(LOC,"^",10)
WRITE !!,"RESIDENT/PROVIDER: ",$SELECT(QA'>0:"________________________",$DATA(^VA(200,QA,0))#2:$EXTRACT($PIECE(^(0),"^"),1,24),1:"________________________")
+8 SET QA=$PIECE(LOC,"^",9)
WRITE ?44,"ATTENDING: ",$SELECT(QA'>0:"_________________________",$DATA(^VA(200,QA,0))#2:$EXTRACT($PIECE(^(0),"^"),1,25),1:"_________________________")
+9 SET QA=$PIECE(LOC,"^",7)
WRITE !!,"TREATING SPECIALTY: ",$SELECT(QA'>0:"_______________________________",$DATA(^DIC(45.7,QA,0))#2:$PIECE(^(0),"^"),1:"_______________________________")
INSTR WRITE !!,"Instructions: Review the medical record and answer the following by circling",!,"the appropriate 'Y' or 'N'. Record any comments at the end of the worksheet.",!,UNDL
+1 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+2 QUIT
