source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMODO3.m@ 1424

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

WorldVistAEHR overlayed on FOIAVistA

File size: 4.2 KB
Line 
1SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98 8:44 PM
2 ;;5.3;Scheduling;**11,25,46,49,159**;Aug 13, 1993
3 Q
4REPORT ;
5 I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT
6START ;
7 N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK
8 S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0
9 W:$E(IOST,1,2)="C-" @IOF
10 F S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV="" D Q:SDFIN
11 . I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN S SDVC=SDIV
12 . S SUB1="" F S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1="" D Q:SDFIN
13 .. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX)
14 .. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV)
15 .. S SUB2="" F S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2="" D Q:SDFIN
16 ... S OEN=0 F S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN S SUBCNT=SUBCNT+1,SDCHECK="" D Q:SDFIN
17 .... S I=0 F S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I S SDFIN='$$PRNT(I) Q:SDFIN
18 S SUBX=$$SUBCNT(SUB1,SUBX)
19EXIT ;
20 K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX
21 Q
22 ;
23SUBCNT(SB1,SB1P) ;
24 I SB1P']""!(SUBCNT'>0) G SUBCNTQ
25 W !,SUBCNT," ",$S(SORT2=1!(SORT2=2):"Primary "_$P($T(SORT+SORT2^SDAMODO1),";;",2),1:$P($T(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$S(SORT1=1!(SORT1=3):$P(SB1P,"^"),SORT1=5:$P($G(^DIC(40.7,SB1P,0)),U),1:SB1P),!!
26 S SUBCNT=0
27SUBCNTQ Q (SB1)
28 ;
29PRNT(I) ;
30 N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID
31 S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0))
32 S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX S SPRV(XX)=""
33 S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX="" S SDX(XX)=""
34 I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ
35 I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ
36 I $Y+5>IOSL S Y='$$HDR(SDIV) G:Y PRNTQ
37LINE1 ;
38 S SDSID=$P($G(SDATA),U,2)
39 W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3)
40 S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1
41 W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds
42 W ?55,$E($P(SDATA,U,3),1,25)
43 W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5))
44 W ?117,$P(SDATA,U,6)
45LINE2 ;
46 S SCODE=$P(SDATA,U,4)
47 W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U)
48 S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
49 S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1
50 S SDONE=0
51 F XX=1:1 D Q:SDONE
52 . I SDDX1'="" S SDDX1=$O(SDX(SDDX1))
53 . I SDPRX'="" S SDPRX=$O(SPRV(SDPRX))
54 . I SDPRX']""&(SDDX1']"") S SDONE=1 Q
55 . I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE
56 . W !
57 . I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
58 . I $D(SDDX1),SORT1'=2 W ?117,SDDX1
59 S Y=1
60PRNTQ S:QFLAG Y=0 Q (Y)
61 ;
62HDR(SDIV) ;
63 N Y
64 S Y=0
65 I SDVC'="",$E(IOST,1,2)="C-" D G:QFLAG HDRQ
66 . K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit"
67 . S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing."
68 . D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q
69 . W @IOF
70 S PAGE=PAGE+1
71 I $E(IOST,1,2)'="C-",SDVC'="" W @IOF
72 W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
73 W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE
74 W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
75 W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U)
76 W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX CODE"
77 W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"-------"
78 S Y=1
79HDRQ Q (Y)
80 ;
81NOREP ;
82 W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
83 W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@")
84 W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
85 W !!,"No data found matching sort parameters"
86 Q
87 ;
88SELPRV(PRV) ;
89 N Y S Y=1
90 I PROVDR=1 G SELPRVQ
91 I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ
92 S Y=0
93SELPRVQ Q (Y)
94 ;
95SELDX(DX) ;
96 N Y S Y=1
97 I PDIAG=1 G SELDXQ
98 S DIC="^ICD9(",DIC(0)="MZ",X=DX
99 D ^DIC K DIC I Y<0 S Y=0 G SELDXQ
100 I $D(PDIAG($P(Y,U))) G SELDXQ
101 S Y=0
102SELDXQ Q (Y)
Note: See TracBrowser for help on using the repository browser.