SDAMODO2 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT, SET-UP DATA ;05 Oct 98 8:43 PM
;;5.3;Scheduling;**11,25,49,132,159,556,586**;Aug 13, 1993;Build 28
;
; Reference to $$ICDDX^ICDEX supported by ICR #5747
; Reference to $$SYS^ICDEX supported by ICR #5747
START ;
U IO
K ^TMP("SDRPT",$J),SDT,SDOE,DOE
S SDT=SDBEG F S SDT=$O(^SCE("B",SDT)) Q:'SDT!(SDT>SDEND) D
. S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE D
.. K SDPRX,SDOE0
.. Q:'$D(^SCE(SDOE,0)) S SDOE0=$G(^SCE(SDOE,0))
.. Q:'$P(SDOE0,U,7)
.. Q:$P(SDOE0,U,6) ;ignore "child" encounters
.. I '$$OKDIV(+$P(SDOE0,U,11)) Q
.. I '$$CHECK(SORT1,SDOE0,SDOE) Q
.. I '$$CHECK(SORT2,SDOE0,SDOE) Q
.. S SDPRX("DFN")=+$P(SDOE0,U,2)
.. S SDPRX("OED")=$P(SDOE0,U)
.. S SDPRX("CL NAME")=$S(+$P($G(SDOE0),U,4)>0:$P(^SC(+$P(SDOE0,U,4),0),U),1:"UNSPECIFIED")
.. S SDPRX("DIV NAME")=+$P(SDOE0,U,11)
.. S SDPRX("PRV")=$$PRV1($S($P($G(SDOE0),U,6)']"":SDOE,1:$P($G(SDOE0),U,6)))
.. S SDPRX("DX")=$$DX1($S($P($G(SDOE0),U,6)']"":SDOE,1:$P($G(SDOE0),U,6)))
.. S SDPRX("SCODE")=+$P(SDOE0,U,3)
.. D BLD(.SDPRX,SORT1,SORT2)
D REPORT^SDAMODO3
EXIT ;
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
Q
;
BLD(SDPRX,SORT1,SORT2) ;
N Y,SUB1,SUB2,PRV
S Y=0
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"))
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"))
F I=1:1 I '$D(^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I)) D Q
. S PRV=$P(SDPRX("PRV"),U),DXCDE=$P(SDPRX("DX"),U)
. D BLDTMP ; build first line
. I SORT1=1 D Q
.. F XX=2:1 S PRV=$P(SDPRX("PRV"),U,XX) Q:PRV']"" D
... S SUB1=$$PRSUB($P(SDPRX("PRV"),U,XX)) D BLDTMP
. I SORT1=2 D Q
.. F XX=2:1 S DXCDE=$P(SDPRX("DX"),U,XX) Q:DXCDE']"" D
... S SUB1=DXCDE D BLDTMP
Q
;
BLDTMP ;
N X1
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
F X1=1:1 Q:'$P($G(SDPRX("PRV")),U,X1) D
. Q:$P($G(SDPRX("PRV")),U,X1)=PRV
. S ^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"PRV",$P($G(SDPRX("PRV")),U,X1))=""
I SORT1'=2 F X1=1:1 Q:$P($G(SDPRX("DX")),U,X1)="" D
. Q:$P($G(SDPRX("DX")),U,X1)=DXCDE
. S ^TMP("SDRPT",$J,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"DX",$P($G(SDPRX("DX")),U,X1))=""
Q
;
PRSUB(PRX) ;
S XPR="UNKNOWN^0"
I +PRX>0 S XPR=$E($P(^VA(200,+PRX,0),U),1,29-$L(+PRX))_"^"_PRX
Q (XPR)
;
PTSUB(PDFN) ;
S XPT=$E($P(^DPT(+PDFN,0),U),1,29-$L(PDFN))_"^"_PDFN
Q (XPT)
;
PDATA(DFN) ;
D PID^VADPT6
Q (VA("PID"))
;
OKDIV(OEDIV) ; check for divisions
N Y
S Y=0
I OEDIV>0,VAUTD!($D(VAUTD(OEDIV))) S Y=1
OKDIVQ Q (Y)
;
CHECK(SRT,SDOE0,OEN) ;
N Y
S Y=0
I SRT=1 S Y=$$PRV(OEN) G CHECKQ
I SRT=2 S Y=$$DX(OEN) G CHECKQ
I SRT=3,$P($G(SDOE0),U,2),PATN!($D(PATN(+$P($G(SDOE0),U,2)))) S Y=1 G CHECKQ
I SRT=4,$P($G(SDOE0),U,4),CLINIC!($D(CLINIC(+$P($G(SDOE0),U,4)))) S Y=1 G CHECKQ
I SRT=5,$P($G(SDOE0),U,3),STOPC!($D(STOPC(+$P($G(SDOE0),U,3)))) S Y=1 G CHECKQ
CHECKQ Q (Y)
;
PRV(OEN) ; -- is there at least one provider from selected list
N Y,SD,PD,SDVPRV,SDVPRVS
S Y=0
D GETPRV^SDOE(OEN,"SDVPRVS")
S SDVPRV=0
F S SDVPRV=$O(SDVPRVS(SDVPRV)) Q:'SDVPRV D Q:Y
. S PD=+SDVPRVS(SDVPRV)
. I PROVDR!($D(PROVDR(PD))) S Y=1 Q
Q Y
;
DX(OEN) ; -- is there at least one dx from selected list
N Y,SD,DXD,SDVPOV,SDVPOVS
S Y=0
D GETDX^SDOE(OEN,"SDVPOVS")
S SDVPOV=0
F S SDVPOV=$O(SDVPOVS(SDVPOV)) Q:'SDVPOV D Q:Y
. S DXD=+SDVPOVS(SDVPOV)
. I PDIAG!($D(PDIAG(DXD))) S Y=1 Q
Q Y
;
PRV1(OEN) ; -- get list of providers for encounter
N PROV,SD,Y,XX,PIFN,PRX,QFLAG,SDVPRV,SDVPRVS
S Y=0,PRX="",QFLAG=0
D GETPRV^SDOE(OEN,"SDVPRVS")
S SDVPRV=0
F S SDVPRV=$O(SDVPRVS(SDVPRV)) Q:'SDVPRV D Q:QFLAG
. S PIFN=+SDVPRVS(SDVPRV)
. IF $D(PROVDR),'PROVDR,'$D(PROVDR(PIFN)) Q
. S PRX=PRX_$S($G(^VA(200,PIFN,0))]"":PIFN,1:"UNKNOWN")_"^"
. S:$L(PRX)>250 QFLAG=1
I PRX']"" S PRX="UNKNOWN"
Q PRX
;
DX1(OEN) ; -- get list of dxs for encounter
N SD,Y,XX,XDX,XDN,QFLAG,SDVPOV,SDVPOVS,SDICD9
S XX=0,XDN="",QFLAG=0
D GETDX^SDOE(OEN,"SDVPOVS")
S SDVPOV=0
F S SDVPOV=$O(SDVPOVS(SDVPOV)) Q:'SDVPOV D Q:QFLAG
. S XX=+SDVPOVS(SDVPOV)
. I $D(PDIAG),'PDIAG,'$D(PDIAG(XX)) Q
. S SDICD9=$$ICDDX^ICDEX(XX,SDBEG,+$$SYS^ICDEX("DIAG",SDBEG,"I"),"I")
. S XDN=XDN_$S($D(SDICD9):$P(SDICD9,U,2)_U,1:"NOT SPECIFIED^")
. S:$L(XDN)>250 QFLAG=1
S:XDN']"" XDN="NOT SPECIFIED"
Q XDN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMODO2 4778 printed Dec 13, 2024@02:47:57 Page 2
SDAMODO2 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT, SET-UP DATA ;05 Oct 98 8:43 PM
+1 ;;5.3;Scheduling;**11,25,49,132,159,556,586**;Aug 13, 1993;Build 28
+2 ;
+3 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+4 ; Reference to $$SYS^ICDEX supported by ICR #5747
START ;
+1 USE IO
+2 KILL ^TMP("SDRPT",$JOB),SDT,SDOE,DOE
+3 SET SDT=SDBEG
FOR
SET SDT=$ORDER(^SCE("B",SDT))
if 'SDT!(SDT>SDEND)
QUIT
Begin DoDot:1
+4 SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("B",SDT,SDOE))
if 'SDOE
QUIT
Begin DoDot:2
+5 KILL SDPRX,SDOE0
+6 if '$DATA(^SCE(SDOE,0))
QUIT
SET SDOE0=$GET(^SCE(SDOE,0))
+7 if '$PIECE(SDOE0,U,7)
QUIT
+8 ;ignore "child" encounters
if $PIECE(SDOE0,U,6)
QUIT
+9 IF '$$OKDIV(+$PIECE(SDOE0,U,11))
QUIT
+10 IF '$$CHECK(SORT1,SDOE0,SDOE)
QUIT
+11 IF '$$CHECK(SORT2,SDOE0,SDOE)
QUIT
+12 SET SDPRX("DFN")=+$PIECE(SDOE0,U,2)
+13 SET SDPRX("OED")=$PIECE(SDOE0,U)
+14 SET SDPRX("CL NAME")=$SELECT(+$PIECE($GET(SDOE0),U,4)>0:$PIECE(^SC(+$PIECE(SDOE0,U,4),0),U),1:"UNSPECIFIED")
+15 SET SDPRX("DIV NAME")=+$PIECE(SDOE0,U,11)
+16 SET SDPRX("PRV")=$$PRV1($SELECT($PIECE($GET(SDOE0),U,6)']"":SDOE,1:$PIECE($GET(SDOE0),U,6)))
+17 SET SDPRX("DX")=$$DX1($SELECT($PIECE($GET(SDOE0),U,6)']"":SDOE,1:$PIECE($GET(SDOE0),U,6)))
+18 SET SDPRX("SCODE")=+$PIECE(SDOE0,U,3)
+19 DO BLD(.SDPRX,SORT1,SORT2)
End DoDot:2
End DoDot:1
+20 DO REPORT^SDAMODO3
EXIT ;
+1 KILL 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
+2 QUIT
+3 ;
BLD(SDPRX,SORT1,SORT2) ;
+1 NEW Y,SUB1,SUB2,PRV
+2 SET Y=0
+3 SET SUB1=$SELECT(SORT1=1:$$PRSUB($PIECE(SDPRX("PRV"),U)),SORT1=2:$PIECE(SDPRX("DX"),U),SORT1=3:$$PTSUB(SDPRX("DFN")),SORT1=4:SDPRX("CL NAME"),SORT1=5:SDPRX("SCODE"))
+4 SET SUB2=$SELECT(SORT2=1:$$PRSUB($PIECE(SDPRX("PRV"),U)),SORT2=2:$PIECE(SDPRX("DX"),U),SORT2=3:$$PTSUB(SDPRX("DFN")),SORT2=4:SDPRX("CL NAME"),SORT2=5:SDPRX("SCODE"))
+5 FOR I=1:1
IF '$DATA(^TMP("SDRPT",$JOB,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I))
Begin DoDot:1
+6 SET PRV=$PIECE(SDPRX("PRV"),U)
SET DXCDE=$PIECE(SDPRX("DX"),U)
+7 ; build first line
DO BLDTMP
+8 IF SORT1=1
Begin DoDot:2
+9 FOR XX=2:1
SET PRV=$PIECE(SDPRX("PRV"),U,XX)
if PRV']""
QUIT
Begin DoDot:3
+10 SET SUB1=$$PRSUB($PIECE(SDPRX("PRV"),U,XX))
DO BLDTMP
End DoDot:3
End DoDot:2
QUIT
+11 IF SORT1=2
Begin DoDot:2
+12 FOR XX=2:1
SET DXCDE=$PIECE(SDPRX("DX"),U,XX)
if DXCDE']""
QUIT
Begin DoDot:3
+13 SET SUB1=DXCDE
DO BLDTMP
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
QUIT
+14 QUIT
+15 ;
BLDTMP ;
+1 NEW X1
+2 SET ^TMP("SDRPT",$JOB,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,0)=SDPRX("DFN")_"^"_$$PDATA(SDPRX("DFN"))_"^"_SDPRX("CL NAME")_"^"_SDPRX("SCODE")_"^"_PRV_"^"_DXCDE
+3 FOR X1=1:1
if '$PIECE($GET(SDPRX("PRV")),U,X1)
QUIT
Begin DoDot:1
+4 if $PIECE($GET(SDPRX("PRV")),U,X1)=PRV
QUIT
+5 SET ^TMP("SDRPT",$JOB,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"PRV",$PIECE($GET(SDPRX("PRV")),U,X1))=""
End DoDot:1
+6 IF SORT1'=2
FOR X1=1:1
if $PIECE($GET(SDPRX("DX")),U,X1)=""
QUIT
Begin DoDot:1
+7 if $PIECE($GET(SDPRX("DX")),U,X1)=DXCDE
QUIT
+8 SET ^TMP("SDRPT",$JOB,SDPRX("DIV NAME"),SUB1,SUB2,SDPRX("OED"),I,"DX",$PIECE($GET(SDPRX("DX")),U,X1))=""
End DoDot:1
+9 QUIT
+10 ;
PRSUB(PRX) ;
+1 SET XPR="UNKNOWN^0"
+2 IF +PRX>0
SET XPR=$EXTRACT($PIECE(^VA(200,+PRX,0),U),1,29-$LENGTH(+PRX))_"^"_PRX
+3 QUIT (XPR)
+4 ;
PTSUB(PDFN) ;
+1 SET XPT=$EXTRACT($PIECE(^DPT(+PDFN,0),U),1,29-$LENGTH(PDFN))_"^"_PDFN
+2 QUIT (XPT)
+3 ;
PDATA(DFN) ;
+1 DO PID^VADPT6
+2 QUIT (VA("PID"))
+3 ;
OKDIV(OEDIV) ; check for divisions
+1 NEW Y
+2 SET Y=0
+3 IF OEDIV>0
IF VAUTD!($DATA(VAUTD(OEDIV)))
SET Y=1
OKDIVQ QUIT (Y)
+1 ;
CHECK(SRT,SDOE0,OEN) ;
+1 NEW Y
+2 SET Y=0
+3 IF SRT=1
SET Y=$$PRV(OEN)
GOTO CHECKQ
+4 IF SRT=2
SET Y=$$DX(OEN)
GOTO CHECKQ
+5 IF SRT=3
IF $PIECE($GET(SDOE0),U,2)
IF PATN!($DATA(PATN(+$PIECE($GET(SDOE0),U,2))))
SET Y=1
GOTO CHECKQ
+6 IF SRT=4
IF $PIECE($GET(SDOE0),U,4)
IF CLINIC!($DATA(CLINIC(+$PIECE($GET(SDOE0),U,4))))
SET Y=1
GOTO CHECKQ
+7 IF SRT=5
IF $PIECE($GET(SDOE0),U,3)
IF STOPC!($DATA(STOPC(+$PIECE($GET(SDOE0),U,3))))
SET Y=1
GOTO CHECKQ
CHECKQ QUIT (Y)
+1 ;
PRV(OEN) ; -- is there at least one provider from selected list
+1 NEW Y,SD,PD,SDVPRV,SDVPRVS
+2 SET Y=0
+3 DO GETPRV^SDOE(OEN,"SDVPRVS")
+4 SET SDVPRV=0
+5 FOR
SET SDVPRV=$ORDER(SDVPRVS(SDVPRV))
if 'SDVPRV
QUIT
Begin DoDot:1
+6 SET PD=+SDVPRVS(SDVPRV)
+7 IF PROVDR!($DATA(PROVDR(PD)))
SET Y=1
QUIT
End DoDot:1
if Y
QUIT
+8 QUIT Y
+9 ;
DX(OEN) ; -- is there at least one dx from selected list
+1 NEW Y,SD,DXD,SDVPOV,SDVPOVS
+2 SET Y=0
+3 DO GETDX^SDOE(OEN,"SDVPOVS")
+4 SET SDVPOV=0
+5 FOR
SET SDVPOV=$ORDER(SDVPOVS(SDVPOV))
if 'SDVPOV
QUIT
Begin DoDot:1
+6 SET DXD=+SDVPOVS(SDVPOV)
+7 IF PDIAG!($DATA(PDIAG(DXD)))
SET Y=1
QUIT
End DoDot:1
if Y
QUIT
+8 QUIT Y
+9 ;
PRV1(OEN) ; -- get list of providers for encounter
+1 NEW PROV,SD,Y,XX,PIFN,PRX,QFLAG,SDVPRV,SDVPRVS
+2 SET Y=0
SET PRX=""
SET QFLAG=0
+3 DO GETPRV^SDOE(OEN,"SDVPRVS")
+4 SET SDVPRV=0
+5 FOR
SET SDVPRV=$ORDER(SDVPRVS(SDVPRV))
if 'SDVPRV
QUIT
Begin DoDot:1
+6 SET PIFN=+SDVPRVS(SDVPRV)
+7 IF $DATA(PROVDR)
IF 'PROVDR
IF '$DATA(PROVDR(PIFN))
QUIT
+8 SET PRX=PRX_$SELECT($GET(^VA(200,PIFN,0))]"":PIFN,1:"UNKNOWN")_"^"
+9 if $LENGTH(PRX)>250
SET QFLAG=1
End DoDot:1
if QFLAG
QUIT
+10 IF PRX']""
SET PRX="UNKNOWN"
+11 QUIT PRX
+12 ;
DX1(OEN) ; -- get list of dxs for encounter
+1 NEW SD,Y,XX,XDX,XDN,QFLAG,SDVPOV,SDVPOVS,SDICD9
+2 SET XX=0
SET XDN=""
SET QFLAG=0
+3 DO GETDX^SDOE(OEN,"SDVPOVS")
+4 SET SDVPOV=0
+5 FOR
SET SDVPOV=$ORDER(SDVPOVS(SDVPOV))
if 'SDVPOV
QUIT
Begin DoDot:1
+6 SET XX=+SDVPOVS(SDVPOV)
+7 IF $DATA(PDIAG)
IF 'PDIAG
IF '$DATA(PDIAG(XX))
QUIT
+8 SET SDICD9=$$ICDDX^ICDEX(XX,SDBEG,+$$SYS^ICDEX("DIAG",SDBEG,"I"),"I")
+9 SET XDN=XDN_$SELECT($DATA(SDICD9):$PIECE(SDICD9,U,2)_U,1:"NOT SPECIFIED^")
+10 if $LENGTH(XDN)>250
SET QFLAG=1
End DoDot:1
if QFLAG
QUIT
+11 if XDN']""
SET XDN="NOT SPECIFIED"
+12 QUIT XDN
