- 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 Apr 23, 2025@18:36:13 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
