source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMODO2.m@ 789

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

initial load of WorldVistAEHR
File size: 4.3 KB
RevLine 
[613]1SDAMODO2 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT, SET-UP DATA ; 05 Oct 98 8:43 PM
2 ;;5.3;Scheduling;**11,25,49,132,159**;Aug 13, 1993
3START ;
4 U IO
5 K ^TMP("SDRPT",$J),SDT,SDOE,DOE
6 S SDT=SDBEG F S SDT=$O(^SCE("B",SDT)) Q:'SDT!(SDT>SDEND) D
7 . S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE D
8 .. K SDPRX,SDOE0
9 .. Q:'$D(^SCE(SDOE,0)) S SDOE0=$G(^SCE(SDOE,0))
10 .. Q:'$P(SDOE0,U,7)
11 .. Q:$P(SDOE0,U,6) ;ignore "child" encounters
12 .. I '$$OKDIV(+$P(SDOE0,U,11)) Q
13 .. I '$$CHECK(SORT1,SDOE0,SDOE) Q
14 .. I '$$CHECK(SORT2,SDOE0,SDOE) Q
15 .. S SDPRX("DFN")=+$P(SDOE0,U,2)
16 .. S SDPRX("OED")=$P(SDOE0,U)
17 .. S SDPRX("CL NAME")=$S(+$P($G(SDOE0),U,4)>0:$P(^SC(+$P(SDOE0,U,4),0),U),1:"UNSPECIFIED")
18 .. S SDPRX("DIV NAME")=+$P(SDOE0,U,11)
19 .. S SDPRX("PRV")=$$PRV1($S($P($G(SDOE0),U,6)']"":SDOE,1:$P($G(SDOE0),U,6)))
20 .. S SDPRX("DX")=$$DX1($S($P($G(SDOE0),U,6)']"":SDOE,1:$P($G(SDOE0),U,6)))
21 .. S SDPRX("SCODE")=+$P(SDOE0,U,3)
22 .. D BLD(.SDPRX,SORT1,SORT2)
23 D REPORT^SDAMODO3
24EXIT ;
25 K DOE,SDOE,SDT,OEDIV,DXD,PD,SD,OEN,SRT,VAR1,DFN,P1,XPR,XPX,XDN,XPT,XDX,DXCDE,SDPRX,VA,VAERR,SDOE0,ZTDESC,%ZIS,ZTSAVE,ZTRTN,ZTSK,ZTQUEUED
26 Q
27 ;
28BLD(SDPRX,SORT1,SORT2) ;
29 N Y,SUB1,SUB2,PRV
30 S Y=0
31 S SUB1=$S(SORT1=1:$$PRSUB($P(SDPRX("PRV"),U)),SORT1=2:$P(SDPRX("DX"),U),SORT1=3:$$PTSUB(SDPRX("DFN")),SORT1=4:SDPRX("CL NAME"),SORT1=5:SDPRX("SCODE"))
32 S SUB2=$S(SORT2=1:$$PRSUB($P(SDPRX("PRV"),U)),SORT2=2:$P(SDPRX("DX"),U),SORT2=3:$$PTSUB(SDPRX("DFN")),SORT2=4:SDPRX("CL NAME"),SORT2=5:SDPRX("SCODE"))
33 F I=1:1 I '$D(^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I)) D Q
34 . S PRV=$P(SDPRX("PRV"),U),DXCDE=$P(SDPRX("DX"),U)
35 . D BLDTMP ; build first line
36 . I SORT1=1 D Q
37 .. F XX=2:1 S PRV=$P(SDPRX("PRV"),U,XX) Q:PRV']"" D
38 ... S SUB1=$$PRSUB($P(SDPRX("PRV"),U,XX)) D BLDTMP
39 . I SORT1=2 D Q
40 .. F XX=2:1 S DXCDE=$P(SDPRX("DX"),U,XX) Q:DXCDE']"" D
41 ... S SUB1=DXCDE D BLDTMP
42 Q
43 ;
44BLDTMP ;
45 N X1
46 S ^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,0)=SDPRX("DFN")_"^"_$$PDATA(SDPRX("DFN"))_"^"_SDPRX("CL NAME")_"^"_SDPRX("SCODE")_"^"_PRV_"^"_DXCDE
47 F X1=1:1 Q:'$P($G(SDPRX("PRV")),U,X1) D
48 . Q:$P($G(SDPRX("PRV")),U,X1)=PRV
49 . S ^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"PRV",$P($G(SDPRX("PRV")),U,X1))=""
50 I SORT1'=2 F X1=1:1 Q:$P($G(SDPRX("DX")),U,X1)="" D
51 . Q:$P($G(SDPRX("DX")),U,X1)=DXCDE
52 . S ^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"DX",$P($G(SDPRX("DX")),U,X1))=""
53 Q
54 ;
55PRSUB(PRX) ;
56 S XPR="UNKNOWN^0"
57 I +PRX>0 S XPR=$E($P(^VA(200,+PRX,0),U),1,29-$L(+PRX))_"^"_PRX
58 Q (XPR)
59 ;
60PTSUB(PDFN) ;
61 S XPT=$E($P(^DPT(+PDFN,0),U),1,29-$L(PDFN))_"^"_PDFN
62 Q (XPT)
63 ;
64PDATA(DFN) ;
65 D PID^VADPT6
66 Q (VA("PID"))
67 ;
68OKDIV(OEDIV) ; check for divisions
69 N Y
70 S Y=0
71 I OEDIV>0,VAUTD!($D(VAUTD(OEDIV))) S Y=1
72OKDIVQ Q (Y)
73 ;
74CHECK(SRT,SDOE0,OEN) ;
75 N Y
76 S Y=0
77 I SRT=1 S Y=$$PRV(OEN) G CHECKQ
78 I SRT=2 S Y=$$DX(OEN) G CHECKQ
79 I SRT=3,$P($G(SDOE0),U,2),PATN!($D(PATN(+$P($G(SDOE0),U,2)))) S Y=1 G CHECKQ
80 I SRT=4,$P($G(SDOE0),U,4),CLINIC!($D(CLINIC(+$P($G(SDOE0),U,4)))) S Y=1 G CHECKQ
81 I SRT=5,$P($G(SDOE0),U,3),STOPC!($D(STOPC(+$P($G(SDOE0),U,3)))) S Y=1 G CHECKQ
82CHECKQ Q (Y)
83 ;
84PRV(OEN) ; -- is there at least one provider from selected list
85 N Y,SD,PD,SDVPRV,SDVPRVS
86 S Y=0
87 D GETPRV^SDOE(OEN,"SDVPRVS")
88 S SDVPRV=0
89 F S SDVPRV=$O(SDVPRVS(SDVPRV)) Q:'SDVPRV D Q:Y
90 . S PD=+SDVPRVS(SDVPRV)
91 . I PROVDR!($D(PROVDR(PD))) S Y=1 Q
92 Q Y
93 ;
94DX(OEN) ; -- is there at least one dx from selected list
95 N Y,SD,DXD,SDVPOV,SDVPOVS
96 S Y=0
97 D GETDX^SDOE(OEN,"SDVPOVS")
98 S SDVPOV=0
99 F S SDVPOV=$O(SDVPOVS(SDVPOV)) Q:'SDVPOV D Q:Y
100 . S DXD=+SDVPOVS(SDVPOV)
101 . I PDIAG!($D(PDIAG(DXD))) S Y=1 Q
102 Q Y
103 ;
104PRV1(OEN) ; -- get list of providers for encounter
105 N PROV,SD,Y,XX,PIFN,PRX,QFLAG,SDVPRV,SDVPRVS
106 S Y=0,PRX="",QFLAG=0
107 D GETPRV^SDOE(OEN,"SDVPRVS")
108 S SDVPRV=0
109 F S SDVPRV=$O(SDVPRVS(SDVPRV)) Q:'SDVPRV D Q:QFLAG
110 . S PIFN=+SDVPRVS(SDVPRV)
111 . IF $D(PROVDR),'PROVDR,'$D(PROVDR(PIFN)) Q
112 . S PRX=PRX_$S($G(^VA(200,PIFN,0))]"":PIFN,1:"UNKNOWN")_"^"
113 . S:$L(PRX)>250 QFLAG=1
114 I PRX']"" S PRX="UNKNOWN"
115 Q PRX
116 ;
117DX1(OEN) ; -- get list of dxs for encounter
118 N SD,Y,XX,XDX,XDN,QFLAG,SDVPOV,SDVPOVS
119 S XX=0,XDN="",QFLAG=0
120 D GETDX^SDOE(OEN,"SDVPOVS")
121 S SDVPOV=0
122 F S SDVPOV=$O(SDVPOVS(SDVPOV)) Q:'SDVPOV D Q:QFLAG
123 . S XX=+SDVPOVS(SDVPOV)
124 . I $D(PDIAG),'PDIAG,'$D(PDIAG(XX)) Q
125 . S XDN=XDN_$S($D(^ICD9(XX,0)):$P(^(0),U)_U,1:"NOT SPECIFIED^")
126 . S:$L(XDN)>250 QFLAG=1
127 S:XDN']"" XDN="NOT SPECIFIED"
128 Q XDN
Note: See TracBrowser for help on using the repository browser.