source: FOIAVistA/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSPCL0.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1QAOSPCL0 ;HISC/DAD-CLINICAL REVIEWER WORKSHEET (PART 1) ;2/12/93 15:16
2 ;;3.0;Occurrence Screen;;09/14/1993
3 I $D(^QA(740,1,"OS"))#2 Q:+$P(^("OS"),"^",3)=0
4 Q:$D(^QA(741,QAOSD0,0))[0 Q:$D(^("SCRN"))[0
5 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=""
6 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:"")
7 S:QAOSDATA=1 QAOSMULT="" S:(QAOSDATA=2)&('$D(^QA(741,QAOSD0,"REVR","B",QAOSCLIN))) QAOSMULT="" S QAOSPRIM=$P(QAOSMULT,"^",4)
8 G:$O(^QA(741.4,"AC",QAOSSCRN,""))="" EXIT D HEAD
9 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
10 G:QAOSQUIT DONE S QAOSHEAD="COMMENTS" W !!,QAOSHEAD S DIWL=4,DIWR=75,DIWF="" K ^UTILITY($J,"W")
11 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
12 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
13DONE D:$E(IOST)="C" PAUSE:'QAOSQUIT W:$E(IOST)'="C" @IOF
14EXIT ;
15 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
16 Q
17LOOP1 ;
18 S QAOSNUM=$P(^QA(741.4,QAOSS0,0),"^",1),X=$P($G(^(1)),"^",1),DIWF="",DIWL=15,DIWR=79
19 K ^UTILITY($J,"W") D ^DIWP I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT S HEADER=0 D HEAD
20 W !!,$J(QAOSNUM,3),$S(QAOSS0=QAOSPRIM:" (Y)/ N",1:" Y / N")
21 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
22 Q
23HEAD ;
24 W:(PAGE>1)!($E(IOST)="C") @IOF
25 W !!?23,"CLINICAL REVIEW WORKSHEET (PART 1)",?68,TODAY,!?68,"PAGE: ",PAGE S PAGE=PAGE+1 D EN6^QAQAUTL
26 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)
27 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:"______________________")
28 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
29 S QA=$P(QAOSMULT,"^",2) W !!,"CLINICAL REVIEWER: ",$S(QA'>0:"________________________________",$D(^VA(200,QA,0))#2:$P(^(0),"^"),1:"________________________________"),?52,"REVIEW DATE: ______________"
30 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:"________________________")
31 S QA=$P(LOC,"^",9) W ?44,"ATTENDING: ",$S(QA'>0:"_________________________",$D(^VA(200,QA,0))#2:$E($P(^(0),"^"),1,25),1:"_________________________")
32 S QA=$P(LOC,"^",7) W !!,"TREATING SPECIALTY: ",$S(QA'>0:"_______________________________",$D(^DIC(45.7,QA,0))#2:$P(^(0),"^"),1:"_______________________________")
33INSTR 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
34 Q
35PAUSE ;
36 K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
37 Q
Note: See TracBrowser for help on using the repository browser.