- QAOSPCL1 ;HISC/DAD-CLINICAL REVIEWER WORKSHEET (PART 2) ;5/7/93 20:27
- ;;3.0;Occurrence Screen;;09/14/1993
- S QAOSPAGE=1,QAOSQUIT=0,QAOSCLIN=$O(^QA(741.2,"C",1,0)),QAOSREVR=1,QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
- S:QAOSDATA=1 QAOSD1="" S:(QAOSDATA=2)&('$D(^QA(741,QAOSD0,"REVR","B",QAOSCLIN))) QAOSD1=""
- S QAOSMULT=$S(QAOSD1'>0:"",$D(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2:^(0),1:"")
- S QA=$P(QAOSMULT,"^",2) S $P(QAOSREVR,"^",2)=$S(QA'>0:"",$D(^VA(200,QA,0))#2:$P(^(0),"^"),1:"")
- S QAOSPAGE=1 D ^QAOSPHDR S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN"))
- K ARRAY F D0=0:0 S D0=$O(^QA(741.5,"C",QAOSSCRN,D0)) Q:D0'>0 S LOC=^QA(741.5,D0,0),X=$D(^QA(741,QAOSD0,"REVR",+QAOSD1,1,"B",D0)) I $P(LOC,"^",4)'>0!X S ARRAY($P(LOC,"^",3)_"^"_$P(LOC,"^"))=$S(X:"_X_",1:"___")
- G:'$D(ARRAY) SKIP1 S QAOSHEAD="REASON(S) FOR EXCEPTION" W !!,QAOSHEAD S DIWL=10,DIWR=75,DIWF="",Y=""
- F QA=0:0 S Y=$O(ARRAY(Y)) Q:Y=""!QAOSQUIT K ^UTILITY($J,"W") S X=$P(Y,"^",2) D ^DIWP W !?3,ARRAY(Y),?8,$J($P(Y,"^"),3) F QA(0)=1:1:^UTILITY($J,"W",DIWL) Q:QAOSQUIT W:QA(0)>1 ! W ?15,^UTILITY($J,"W",DIWL,QA(0),0) D CHK
- G:QAOSQUIT EXIT
- SKIP1 ;
- S QAOSHEAD="FINDINGS" W !!,QAOSHEAD
- F QA=0:0 S QA=$O(^QA(741.6,"B",QA)) Q:QA'>0!QAOSQUIT F D0=0:0 S D0=$O(^QA(741.6,"B",QA,D0)) Q:D0'>0!QAOSQUIT S LOC=^QA(741.6,D0,0) I $P(LOC,"^",3)["1" W !?3,$S($P(QAOSMULT,"^",5)=D0:"_X_",1:"___"),?8,$J(QA,3,0),?15,$P(LOC,"^",2) D CHK
- G:QAOSQUIT EXIT
- S QAOSHEAD="PRIMARY REASON CLIN REFERRAL" W !!,QAOSHEAD S QA=$P(QAOSMULT,"^",4) I QA'>0 W ": __________________________________________________" G SKIP2
- S QA(0)=$P(^QA(741.4,QA,0),"^"),X=$P($G(^(1)),"^"),DIWL=10,DIWR=75,DIWF="" K ^UTILITY($J,"W") D ^DIWP W !?3,"_X_",?8,$J(QA(0),3) F QA=1:1:^UTILITY($J,"W",DIWL) Q:QAOSQUIT W:QA>1 ! W ?15,^UTILITY($J,"W",DIWL,QA,0) D CHK
- G:QAOSQUIT EXIT
- SKIP2 ;
- K ARRAY
- F QA=0:0 S QA=$O(^QA(741.7,"B",QA)) Q:QA'>0 F D0=0:0 S D0=$O(^QA(741.7,"B",QA,D0)) Q:D0'>0 S LOC=^QA(741.7,D0,0) I $P(LOC,"^",2)["1" S ARRAY(+LOC)=$S(QAOSD1'>0:"___",$D(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",D0)):"_X_",1:"___")_"^"_$P(LOC,"^",3)
- S QAOSHEAD="ACTION(S)" W !!,QAOSHEAD F QA=0:0 S QA=$O(ARRAY(QA)) Q:QA'>0!QAOSQUIT W !?3,$P(ARRAY(QA),"^"),?8,$J(QA,3),?15,$P(ARRAY(QA),"^",2) D CHK
- G:QAOSQUIT EXIT
- W !!,"DATE REVIEW COMPLETED: " S Y=$P(QAOSMULT,"^",3) X ^DD("DD") W $S(Y]"":Y,1:"____________________") D CHK G:QAOSQUIT EXIT
- S QAOSHEAD="" W !!,"Should the care in this case be considered for educational presentations" D CHK Q:QAOSQUIT
- W !,"because it was exemplary? ___ YES, ___ NO. If YES, describe." D CHK Q:QAOSQUIT
- 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) D CHK
- G:QAOSQUIT EXIT
- BLANK I $Y<(IOSL-6) W ! G BLANK
- W !,"SIGNATURE"
- EXIT ;
- I ('QAOSQUIT)&($E(IOST)="C") K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
- W:$E(IOST)'="C" @IOF
- EXIT0 K ARRAY,D0,DIWF,DIWL,DIWR,LOC,QA,QAOSCLIN,QAOSD1,QAOSHEAD,QAOSMULT,QAOSPAGE,QAOSREVR,QAOSSCRN,X,XX,Y
- Q
- CHK ;
- Q:$Y'>(IOSL-6) N D0,QA,Y I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0) Q:QAOSQUIT
- D ^QAOSPHDR W !!,QAOSHEAD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPCL1 3373 printed Apr 23, 2025@18:36:14 Page 2
- QAOSPCL1 ;HISC/DAD-CLINICAL REVIEWER WORKSHEET (PART 2) ;5/7/93 20:27
- +1 ;;3.0;Occurrence Screen;;09/14/1993
- +2 SET QAOSPAGE=1
- SET QAOSQUIT=0
- SET QAOSCLIN=$ORDER(^QA(741.2,"C",1,0))
- SET QAOSREVR=1
- SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
- +3 if QAOSDATA=1
- SET QAOSD1=""
- if (QAOSDATA=2)&('$DATA(^QA(741,QAOSD0,"REVR","B",QAOSCLIN)))
- SET QAOSD1=""
- +4 SET QAOSMULT=$SELECT(QAOSD1'>0:"",$DATA(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2:^(0),1:"")
- +5 SET QA=$PIECE(QAOSMULT,"^",2)
- SET $PIECE(QAOSREVR,"^",2)=$SELECT(QA'>0:"",$DATA(^VA(200,QA,0))#2:$PIECE(^(0),"^"),1:"")
- +6 SET QAOSPAGE=1
- DO ^QAOSPHDR
- SET QAOSSCRN=+$GET(^QA(741,QAOSD0,"SCRN"))
- +7 KILL ARRAY
- FOR D0=0:0
- SET D0=$ORDER(^QA(741.5,"C",QAOSSCRN,D0))
- if D0'>0
- QUIT
- SET LOC=^QA(741.5,D0,0)
- SET X=$DATA(^QA(741,QAOSD0,"REVR",+QAOSD1,1,"B",D0))
- IF $PIECE(LOC,"^",4)'>0!X
- SET ARRAY($PIECE(LOC,"^",3)_"^"_$PIECE(LOC,"^"))=$SELECT(X:"_X_",1:"___")
- +8 if '$DATA(ARRAY)
- GOTO SKIP1
- SET QAOSHEAD="REASON(S) FOR EXCEPTION"
- WRITE !!,QAOSHEAD
- SET DIWL=10
- SET DIWR=75
- SET DIWF=""
- SET Y=""
- +9 FOR QA=0:0
- SET Y=$ORDER(ARRAY(Y))
- if Y=""!QAOSQUIT
- QUIT
- KILL ^UTILITY($JOB,"W")
- SET X=$PIECE(Y,"^",2)
- DO ^DIWP
- WRITE !?3,ARRAY(Y),?8,$JUSTIFY($PIECE(Y,"^"),3)
- FOR QA(0)=1:1:^UTILITY($JOB,"W",DIWL)
- if QAOSQUIT
- QUIT
- if QA(0)>1
- WRITE !
- WRITE ?15,^UTILITY($JOB,"W",DIWL,QA(0),0)
- DO CHK
- +10 if QAOSQUIT
- GOTO EXIT
- SKIP1 ;
- +1 SET QAOSHEAD="FINDINGS"
- WRITE !!,QAOSHEAD
- +2 FOR QA=0:0
- SET QA=$ORDER(^QA(741.6,"B",QA))
- if QA'>0!QAOSQUIT
- QUIT
- FOR D0=0:0
- SET D0=$ORDER(^QA(741.6,"B",QA,D0))
- if D0'>0!QAOSQUIT
- QUIT
- SET LOC=^QA(741.6,D0,0)
- IF $PIECE(LOC,"^",3)["1"
- WRITE !?3,$SELECT($PIECE(QAOSMULT,"^",5)=D0:"_X_",1:"___"),?8,$JUSTIFY(QA,3,0),?15,$PIECE(LOC,"^",2)
- DO CHK
- +3 if QAOSQUIT
- GOTO EXIT
- +4 SET QAOSHEAD="PRIMARY REASON CLIN REFERRAL"
- WRITE !!,QAOSHEAD
- SET QA=$PIECE(QAOSMULT,"^",4)
- IF QA'>0
- WRITE ": __________________________________________________"
- GOTO SKIP2
- +5 SET QA(0)=$PIECE(^QA(741.4,QA,0),"^")
- SET X=$PIECE($GET(^(1)),"^")
- SET DIWL=10
- SET DIWR=75
- SET DIWF=""
- KILL ^UTILITY($JOB,"W")
- DO ^DIWP
- WRITE !?3,"_X_",?8,$JUSTIFY(QA(0),3)
- FOR QA=1:1:^UTILITY($JOB,"W",DIWL)
- if QAOSQUIT
- QUIT
- if QA>1
- WRITE !
- WRITE ?15,^UTILITY($JOB,"W",DIWL,QA,0)
- DO CHK
- +6 if QAOSQUIT
- GOTO EXIT
- SKIP2 ;
- +1 KILL ARRAY
- +2 FOR QA=0:0
- SET QA=$ORDER(^QA(741.7,"B",QA))
- if QA'>0
- QUIT
- FOR D0=0:0
- SET D0=$ORDER(^QA(741.7,"B",QA,D0))
- if D0'>0
- QUIT
- SET LOC=^QA(741.7,D0,0)
- IF $PIECE(LOC,"^",2)["1"
- SET ARRAY(+LOC)=$SELECT(QAOSD1'>0:"___",$DATA(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",D0)):"_X_",1:"___")_"^"_$PIECE(LOC,"^",3)
- +3 SET QAOSHEAD="ACTION(S)"
- WRITE !!,QAOSHEAD
- FOR QA=0:0
- SET QA=$ORDER(ARRAY(QA))
- if QA'>0!QAOSQUIT
- QUIT
- WRITE !?3,$PIECE(ARRAY(QA),"^"),?8,$JUSTIFY(QA,3),?15,$PIECE(ARRAY(QA),"^",2)
- DO CHK
- +4 if QAOSQUIT
- GOTO EXIT
- +5 WRITE !!,"DATE REVIEW COMPLETED: "
- SET Y=$PIECE(QAOSMULT,"^",3)
- XECUTE ^DD("DD")
- WRITE $SELECT(Y]"":Y,1:"____________________")
- DO CHK
- if QAOSQUIT
- GOTO EXIT
- +6 SET QAOSHEAD=""
- WRITE !!,"Should the care in this case be considered for educational presentations"
- DO CHK
- if QAOSQUIT
- QUIT
- +7 WRITE !,"because it was exemplary? ___ YES, ___ NO. If YES, describe."
- DO CHK
- if QAOSQUIT
- QUIT
- +8 SET QAOSHEAD="COMMENTS"
- WRITE !!,QAOSHEAD
- SET DIWL=4
- SET DIWR=75
- SET DIWF=""
- KILL ^UTILITY($JOB,"W")
- +9 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
- +10 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)
- DO CHK
- +11 if QAOSQUIT
- GOTO EXIT
- BLANK IF $Y<(IOSL-6)
- WRITE !
- GOTO BLANK
- +1 WRITE !,"SIGNATURE"
- EXIT ;
- +1 IF ('QAOSQUIT)&($EXTRACT(IOST)="C")
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
- +2 if $EXTRACT(IOST)'="C"
- WRITE @IOF
- EXIT0 KILL ARRAY,D0,DIWF,DIWL,DIWR,LOC,QA,QAOSCLIN,QAOSD1,QAOSHEAD,QAOSMULT,QAOSPAGE,QAOSREVR,QAOSSCRN,X,XX,Y
- +1 QUIT
- CHK ;
- +1 if $Y'>(IOSL-6)
- QUIT
- NEW D0,QA,Y
- IF $EXTRACT(IOST)="C"
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
- if QAOSQUIT
- QUIT
- +2 DO ^QAOSPHDR
- WRITE !!,QAOSHEAD
- +3 QUIT
