Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDAMODO2

SDAMODO2.m

Go to the documentation of this file. 
  1. SDAMODO2 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT, SET-UP DATA ; 05 Oct 98  8:43 PM
  1.  ;;5.3;PIMS;**11,25,49,132,159,1015,1016**;JUN 30, 2012;Build 20
  1. START ;
  1.  U IO
  1.  K ^TMP("SDRPT",$J),SDT,SDOE,DOE
  1.  S SDT=SDBEG F  S SDT=$O(^SCE("B",SDT)) Q:'SDT!(SDT>SDEND)  D
  1.  . S SDOE=0 F  S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE  D
  1.  .. K SDPRX,SDOE0
  1.  .. Q:'$D(^SCE(SDOE,0))  S SDOE0=$G(^SCE(SDOE,0))
  1.  .. Q:'$P(SDOE0,U,7)
  1.  .. Q:$P(SDOE0,U,6)  ;ignore "child" encounters
  1.  .. I '$$OKDIV(+$P(SDOE0,U,11)) Q
  1.  .. I '$$CHECK(SORT1,SDOE0,SDOE) Q
  1.  .. I '$$CHECK(SORT2,SDOE0,SDOE) Q
  1.  .. S SDPRX("DFN")=+$P(SDOE0,U,2)
  1.  .. S SDPRX("OED")=$P(SDOE0,U)
  1.  .. S SDPRX("CL NAME")=$S(+$P($G(SDOE0),U,4)>0:$P(^SC(+$P(SDOE0,U,4),0),U),1:"UNSPECIFIED")
  1.  .. S SDPRX("DIV NAME")=+$P(SDOE0,U,11)
  1.  .. S SDPRX("PRV")=$$PRV1($S($P($G(SDOE0),U,6)']"":SDOE,1:$P($G(SDOE0),U,6)))
  1.  .. S SDPRX("DX")=$$DX1($S($P($G(SDOE0),U,6)']"":SDOE,1:$P($G(SDOE0),U,6)))
  1.  .. S SDPRX("SCODE")=+$P(SDOE0,U,3)
  1.  .. D BLD(.SDPRX,SORT1,SORT2)
  1.  D REPORT^SDAMODO3
  1. EXIT ;
  1.  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
  1.  Q
  1.  ;
  1. BLD(SDPRX,SORT1,SORT2) ;
  1.  N Y,SUB1,SUB2,PRV
  1.  S Y=0
  1.  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"))
  1.  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"))
  1.  F I=1:1 I '$D(^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I)) D  Q
  1.  . S PRV=$P(SDPRX("PRV"),U),DXCDE=$P(SDPRX("DX"),U)
  1.  . D BLDTMP ; build first line
  1.  . I SORT1=1 D  Q
  1.  .. F XX=2:1 S PRV=$P(SDPRX("PRV"),U,XX)  Q:PRV']""  D
  1.  ... S SUB1=$$PRSUB($P(SDPRX("PRV"),U,XX)) D BLDTMP
  1.  . I SORT1=2 D  Q
  1.  .. F XX=2:1 S DXCDE=$P(SDPRX("DX"),U,XX) Q:DXCDE']""  D
  1.  ... S SUB1=DXCDE D BLDTMP
  1.  Q
  1.  ;
  1. BLDTMP ;
  1.  N X1
  1.  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
  1.  F X1=1:1 Q:'$P($G(SDPRX("PRV")),U,X1)  D
  1.  . Q:$P($G(SDPRX("PRV")),U,X1)=PRV
  1.  . S ^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"PRV",$P($G(SDPRX("PRV")),U,X1))=""
  1.  I SORT1'=2 F X1=1:1 Q:$P($G(SDPRX("DX")),U,X1)=""  D
  1.  . Q:$P($G(SDPRX("DX")),U,X1)=DXCDE
  1.  . S ^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"DX",$P($G(SDPRX("DX")),U,X1))=""
  1.  Q
  1.  ;
  1. PRSUB(PRX) ;
  1.  S XPR="UNKNOWN^0"
  1.  I +PRX>0 S XPR=$E($P(^VA(200,+PRX,0),U),1,29-$L(+PRX))_"^"_PRX
  1.  Q (XPR)
  1.  ;
  1. PTSUB(PDFN) ;
  1.  S XPT=$E($P(^DPT(+PDFN,0),U),1,29-$L(PDFN))_"^"_PDFN
  1.  Q (XPT)
  1.  ;
  1. PDATA(DFN) ;
  1.  D PID^VADPT6
  1.  Q (VA("PID"))
  1.  ;
  1. OKDIV(OEDIV)    ;   check for divisions
  1.  N Y
  1.  S Y=0
  1.  I OEDIV>0,VAUTD!($D(VAUTD(OEDIV))) S Y=1
  1. OKDIVQ Q (Y)
  1.  ;
  1. CHECK(SRT,SDOE0,OEN) ;
  1.  N Y
  1.  S Y=0
  1.  I SRT=1 S Y=$$PRV(OEN) G CHECKQ
  1.  I SRT=2 S Y=$$DX(OEN) G CHECKQ
  1.  I SRT=3,$P($G(SDOE0),U,2),PATN!($D(PATN(+$P($G(SDOE0),U,2)))) S Y=1 G CHECKQ
  1.  I SRT=4,$P($G(SDOE0),U,4),CLINIC!($D(CLINIC(+$P($G(SDOE0),U,4)))) S Y=1 G CHECKQ
  1.  I SRT=5,$P($G(SDOE0),U,3),STOPC!($D(STOPC(+$P($G(SDOE0),U,3)))) S Y=1 G CHECKQ
  1. CHECKQ Q (Y)
  1.  ;
  1. PRV(OEN) ; -- is there at least one provider from selected list
  1.  N Y,SD,PD,SDVPRV,SDVPRVS
  1.  S Y=0
  1.  D GETPRV^SDOE(OEN,"SDVPRVS")
  1.  S SDVPRV=0
  1.  F  S SDVPRV=$O(SDVPRVS(SDVPRV)) Q:'SDVPRV  D  Q:Y
  1.  . S PD=+SDVPRVS(SDVPRV)
  1.  . I PROVDR!($D(PROVDR(PD))) S Y=1  Q
  1.  Q Y
  1.  ;
  1. DX(OEN) ; -- is there at least one dx from selected list
  1.  N Y,SD,DXD,SDVPOV,SDVPOVS
  1.  S Y=0
  1.  D GETDX^SDOE(OEN,"SDVPOVS")
  1.  S SDVPOV=0
  1.  F  S SDVPOV=$O(SDVPOVS(SDVPOV)) Q:'SDVPOV  D  Q:Y
  1.  . S DXD=+SDVPOVS(SDVPOV)
  1.  . I PDIAG!($D(PDIAG(DXD))) S Y=1 Q
  1.  Q Y
  1.  ;
  1. PRV1(OEN) ; -- get list of providers for encounter
  1.  N PROV,SD,Y,XX,PIFN,PRX,QFLAG,SDVPRV,SDVPRVS
  1.  S Y=0,PRX="",QFLAG=0
  1.  D GETPRV^SDOE(OEN,"SDVPRVS")
  1.  S SDVPRV=0
  1.  F  S SDVPRV=$O(SDVPRVS(SDVPRV)) Q:'SDVPRV  D  Q:QFLAG
  1.  . S PIFN=+SDVPRVS(SDVPRV)
  1.  . IF $D(PROVDR),'PROVDR,'$D(PROVDR(PIFN)) Q
  1.  . S PRX=PRX_$S($G(^VA(200,PIFN,0))]"":PIFN,1:"UNKNOWN")_"^"
  1.  . S:$L(PRX)>250 QFLAG=1
  1.  I PRX']"" S PRX="UNKNOWN"
  1.  Q PRX
  1.  ;
  1. DX1(OEN) ; -- get list of dxs for encounter
  1.  N SD,Y,XX,XDX,XDN,QFLAG,SDVPOV,SDVPOVS,SDICD9
  1.  S XX=0,XDN="",QFLAG=0
  1.  D GETDX^SDOE(OEN,"SDVPOVS")
  1.  S SDVPOV=0
  1.  F  S SDVPOV=$O(SDVPOVS(SDVPOV)) Q:'SDVPOV  D  Q:QFLAG
  1.  . S XX=+SDVPOVS(SDVPOV)
  1.  . I $D(PDIAG),'PDIAG,'$D(PDIAG(XX)) Q
  1.  . S SDICD9=$$ICDDX^ICDCODE(XX)
  1.  . S XDN=XDN_$S($D(SDICD9):$P(SDICD9,U,2)_U,1:"NOT SPECIFIED^")
  1.  . S:$L(XDN)>250 QFLAG=1
  1.  S:XDN']"" XDN="NOT SPECIFIED"
  1.  Q XDN