source: FOIAVistA/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSPAD1.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: 2.5 KB
Line 
1QAOSPAD1 ;HISC/DAD-ADVERSE FINDINGS REPORT ;2/12/93 15:13
2 ;;3.0;Occurrence Screen;;09/14/1993
3 S QAOSQUIT=0,PAGE=1,Y=DT X ^DD("DD") S TODAY=$P(Y,"@") K UNDL S $P(UNDL,"-",80)="-"
4 D HEAD I '$D(^TMP($J,"A")) W !!,"NO DATA FOUND FOR THIS REPORT" G EXIT
5 S SERV="" F SRV=0:0 S SERV=$O(^TMP($J,"A",SERV)) Q:SERV=""!QAOSQUIT D SUBHEAD S PAT="" F PT=0:0 S PAT=$O(^TMP($J,"A",SERV,PAT)) Q:PAT=""!QAOSQUIT F SCRN=0:0 S SCRN=$O(^TMP($J,"A",SERV,PAT,SCRN)) Q:SCRN'>0!QAOSQUIT D LOOP1
6EXIT ;
7 Q
8LOOP1 ;
9 F DATE=0:0 S DATE=$O(^TMP($J,"A",SERV,PAT,SCRN,DATE)) Q:DATE'>0!QAOSQUIT D LOOP2
10 Q
11LOOP2 ;
12 S LOC=^TMP($J,"A",SERV,PAT,SCRN,DATE),SSN=$P(LOC,"^"),FIND=$P(LOC,"^",2),STATUS=$P(LOC,"^",3),ATTEND=$P(LOC,"^",4),PROV=$P(LOC,"^",5),TEAM=$P(LOC,"^",6),QAOSD0=$P(LOC,"^",7),Y=DATE\1 X ^DD("DD")
13 W:QAOSCHOS'="X" ! W !!,PAT,?32,SSN,?43,Y,?56,SCRN,?63,STATUS,?71,FIND
14 W !,$E(ATTEND,1,25),?27,$E(TEAM,1,25),?54,$E(PROV,1,25)
15 I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD
16 Q:QAOSCHOS="X" S (DI,DM,DH)=.001
17 I $O(^QA(741,QAOSD0,"ATRI",0))!$O(^QA(741,QAOSD0,"ATRT",0))!$O(^QA(741,QAOSD0,"ATRL",0)) W !,"-ATTRIBUTION(INDIVIDUAL)-",?27,"-ATTRIBUTION(MEDICAL TEAM)-",?56,"-ATTRIBUTION(HOSP LOC)-"
18 E Q
19LOOP3 ;
20 W ! D INDIV:DI,TEAM:DM,HOSPL:DH
21 I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD W:$O(^QA(741,QAOSD0,"ATRI",DI))!$O(^QA(741,QAOSD0,"ATRT",DM))!$O(^QA(741,QAOSD0,"ATRL",DH)) !,"-ATTRIBUTION(INDIVIDUAL)-",?27,"-ATTRIBUTION(MEDICAL TEAM)-",?56,"-ATTRIBUTION(HOSP LOC)-"
22 G:DI!DM!DH LOOP3
23 Q
24INDIV ;
25 S DI=$O(^QA(741,QAOSD0,"ATRI",DI)) Q:DI'>0 S X=$S($D(^QA(741,QAOSD0,"ATRI",DI,0))#2:+^(0),1:""),X=$S(X'>0:X,($D(^VA(200,X,0))#2)&(QAOSCHOS="N"):$P(^(0),"^"),1:X) W $E(X,1,25)
26 Q
27TEAM ;
28 S DM=$O(^QA(741,QAOSD0,"ATRT",DM)) Q:DM'>0 S X=$S($D(^QA(741,QAOSD0,"ATRT",DM,0))#2:+^(0),1:""),X=$S(X'>0:X,($D(^QA(741.93,X,0))#2)&(QAOSCHOS="N"):$P(^(0),"^"),1:X) W ?27,$E(X,1,25)
29 Q
30HOSPL ;
31 S DH=$O(^QA(741,QAOSD0,"ATRL",DH)) Q:DH'>0 S X=$S($D(^QA(741,QAOSD0,"ATRL",DH,0))#2:+^(0),1:""),X=$S(X'>0:X,($D(^SC(X,0))#2)&(QAOSCHOS="N"):$P(^(0),"^"),1:X) W ?56,$E(X,1,25)
32 Q
33HEAD ;
34 W:(PAGE>1)!($E(IOST)="C") @IOF
35 W !!?32,"ADVERSE FINDINGS",?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE S PAGE=PAGE+1
36 D EN6^QAQAUTL
37 W !,"PATIENT",?32,"SSN",?43,"OCCURRENCE",?56,"SCREEN",?63,"STATUS",?71,"LEVEL" W:QAOSCHOS'="X" !,"ATTENDING PHYSICIAN",?27,"MEDICAL TEAM",?54,"RESIDENT/PROVIDER" W !,UNDL
38 Q
39SUBHEAD ;
40 W !!?3,"SERVICE: ",$S(SERV["~":$P(SERV,"~",2),1:SERV)
41 Q
42PAUSE ;
43 K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
44 Q
Note: See TracBrowser for help on using the repository browser.