source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSPSR0.m@ 701

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1QAOSPSR0 ;HISC/DAD-OCCURRENCE SCREENS BY SERVICE ;2/12/93 15:26
2 ;;3.0;Occurrence Screen;;09/14/1993
3 D ^QAQDATE G:QAQQUIT EXIT K %ZIS,IOP
4 K ^UTILITY($J,"P"),^UTILITY($J,"QAOSSCRN"),^UTILITY($J,"QAOSSERV")
5 K QAQDIC S QAQDIC="^DIC(49,",QAQDIC(0)="AEMNQZ",QAQDIC("A")="Select SERVICE: "
6 S QAQUTIL="QAOSSERV" D ^QAQSELCT G:QAQQUIT EXIT
7 K QAQDIC S QAQDIC="^QA(741.1,",QAQDIC(0)="AEMNQZ",QAQDIC("A")="Select SCREEN: "
8 S QAQDIC("B")="ALL",QAQUTIL="QAOSSCRN" D ^QAQSELCT G:QAQQUIT EXIT
9DEV ;
10 K %ZIS S %ZIS="QM" W ! D ^%ZIS G:POP EXIT
11 I $D(IO("Q")) S ZTRTN="ENTSK^QAOSPSR0",ZTDESC="Occurrences by service",(ZTSAVE("QAO*"),ZTSAVE("QAQ*"),ZTSAVE("^UTILITY($J,"))="" D ^%ZTLOAD G EXIT
12ENTSK ;
13 S QAOSQUIT=0 F QAOSDATE=QAQNBEG-.0000001:0 S QAOSDATE=$O(^QA(741,"C",QAOSDATE)) Q:(QAOSDATE'>0)!(QAOSDATE>QAQNEND)!(QAOSQUIT) F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDATE,QAOSD0)) Q:QAOSD0'>0 D LOOP1
14PRINT ;
15 U IO S SERV="",Y=DT X ^DD("DD") S TODAY=$P(Y,"@"),PAGE=1 K UNDL S $P(UNDL,"-",80)="-",QAOSQUIT=0 I '$D(^UTILITY($J,"P")) D HEAD W !!,"*** NO OCCURRENCES FOUND IN THE SELECTED DATE RANGE ***" G EXIT
16 F SER=0:1 S SERV=$O(^UTILITY($J,"P",SERV)) Q:SERV=""!QAOSQUIT D PAUSE:$E(IOST)="C"&SER Q:QAOSQUIT D HEAD,SUBHEAD,PRT1
17EXIT ;
18 W ! D ^%ZISC
19 K %ZIS,DATE,LOC,NAM,NAME,PAGE,POP,QAOSD0,QAOSDATE,QAOSQUIT,SCRN,SCRNTXT,SER,SERV,SSN,STAT,TODAY,TXSP,UNDL,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE,%DT,D,I,Y,QAQDIC,QAQUTIL,^UTILITY($J,"P"),^UTILITY($J,"QAOSSCRN"),^UTILITY($J,"QAOSSERV")
20 D K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"
21 Q
22PRT1 ;
23 F SCRN=0:0 S SCRN=$O(^UTILITY($J,"P",SERV,SCRN)) Q:SCRN'>0!QAOSQUIT S NAME="" F NAM=0:0 S NAME=$O(^UTILITY($J,"P",SERV,SCRN,NAME)) Q:NAME=""!QAOSQUIT F DATE=0:0 S DATE=$O(^UTILITY($J,"P",SERV,SCRN,NAME,DATE)) Q:DATE'>0!QAOSQUIT D PRT2
24 Q
25PRT2 ;
26 S LOC=^UTILITY($J,"P",SERV,SCRN,NAME,DATE),TXSP=$P(LOC,"^"),SCRNTXT=$P(LOC,"^",2),STAT=$P(LOC,"^",3),SSN=$P(LOC,"^",4),Y=DATE\1 X ^DD("DD")
27 W !!,NAME,?32,SSN,?43,Y,?56,STAT,?65,$E(TXSP,1,15),!?1,SCRN,?8,$E(SCRNTXT,1,72)
28 S Z=$O(^UTILITY($J,"P",SERV,SCRN))_$O(^UTILITY($J,"P",SERV,SCRN,NAME))_$O(^UTILITY($J,"P",SERV,SCRN,NAME,DATE))
29 I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE:Z]"" Q:QAOSQUIT D:Z]"" HEAD,SUBHEAD
30 Q
31LOOP1 ;
32 S LOC=^QA(741,QAOSD0,0),SCRN=+$G(^("SCRN")),SCRNTXT="" S:$D(^QA(741.1,SCRN,0))#2 SCRN=+^(0),SCRNTXT=$P(^(0),"^",2)
33 Q:$D(^UTILITY($J,"QAOSSCRN",SCRN,SCRN))[0
34 S SERV=$P(LOC,"^",6),TXSP=$P(LOC,"^",7),STAT=$P(LOC,"^",11) Q:STAT=2 S STAT=$S(STAT=1:"CLOSED",1:"OPEN")
35 S NAME=+LOC,LOC=$G(^DPT(+LOC,0)),NAME=$S($P(LOC,"^")]"":$P(LOC,"^"),1:NAME),SSN=$P(LOC,"^",9) S:NAME="" NAME=+LOC
36 S SERV(0)=$P($G(^DIC(49,+SERV,0)),"^") Q:SERV(0)=""
37 Q:$D(^UTILITY($J,"QAOSSERV",SERV(0),SERV))[0
38 S:TXSP]"" TXSP=$S($D(^DIC(45.7,TXSP,0))#2:$P(^(0),"^"),1:TXSP)
39 S ^UTILITY($J,"P",SERV(0),SCRN,NAME,QAOSDATE)=TXSP_"^"_SCRNTXT_"^"_STAT_"^"_SSN
40 Q
41HEAD ;
42 W:(PAGE>1)!($E(IOST)="C") @IOF
43 W !!?29,"OCCURRENCES BY SERVICE",?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE S PAGE=PAGE+1
44 D EN6^QAQAUTL
45 W !,"PATIENT / SCREEN",?32,"SSN",?43,"DATE",?56,"STATUS",?65,"TREATING SPEC.",!,UNDL
46 Q
47 Q
48SUBHEAD ;
49 W !!," SERVICE: ",SERV
50 Q
51PAUSE ;
52 K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
53 Q
Note: See TracBrowser for help on using the repository browser.