SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ;05 Oct 98 8:44 PM
;;5.3;Scheduling;**11,25,46,49,159,529,586**;Aug 13, 1993;Build 28
Q
REPORT ;
I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT
START ;
N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK
S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0
W:$E(IOST,1,2)="C-" @IOF
F S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV="" D Q:SDFIN
. I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN S SDVC=SDIV
. S SUB1="" F S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1="" D Q:SDFIN
.. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX)
.. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV)
.. S SUB2="" F S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2="" D Q:SDFIN
... S OEN=0 F S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN S SUBCNT=SUBCNT+1,SDCHECK="" D Q:SDFIN
.... S I=0 F S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I S SDFIN='$$PRNT(I) Q:SDFIN
S SUBX=$$SUBCNT(SUB1,SUBX)
EXIT ;
K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX
Q
;
SUBCNT(SB1,SB1P) ;
I SB1P']""!(SUBCNT'>0) G SUBCNTQ
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),!!
S SUBCNT=0
SUBCNTQ Q (SB1)
;
PRNT(I) ;
N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID
S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0))
S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX S SPRV(XX)=""
S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX="" S SDX(XX)=""
I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ
I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ
I $Y+5>IOSL S Y='$$HDR(SDIV) G:Y PRNTQ
LINE1 ;
S SDSID=$P($G(SDATA),U,2)
W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3)
S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1
W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds
W ?55,$E($P(SDATA,U,3),1,25)
W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5))
W ?117,$P(SDATA,U,6)
LINE2 ;
S SCODE=$P(SDATA,U,4)
W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U)
S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1
S SDONE=0
F XX=1:1 D Q:SDONE
. I SDDX1'="" S SDDX1=$O(SDX(SDDX1))
. I SDPRX'="" S SDPRX=$O(SPRV(SDPRX))
. I SDPRX']""&(SDDX1']"") S SDONE=1 Q
. I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE
. W !
. I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
. I $D(SDDX1),SORT1'=2 W ?117,SDDX1
S Y=1
PRNTQ S:QFLAG Y=0 Q (Y)
;
HDR(SDIV) ;
N Y
S Y=0
I SDVC'="",$E(IOST,1,2)="C-" D G:QFLAG HDRQ
. K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit"
. S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing."
. D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q
. W @IOF
S PAGE=PAGE+1
I $E(IOST,1,2)'="C-",SDVC'="" W @IOF
W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE
W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U)
; SSA ICD-10
W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX "_$S(SDBEG<ICD10IMPDT:"(ICD9)",1:"(ICD10)")_" CODE"
W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"---------------"
S Y=1
HDRQ Q (Y)
;
NOREP ;
W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@")
W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
W !!,"No data found matching sort parameters"
Q
;
SELPRV(PRV) ;
N Y S Y=1
I PROVDR=1 G SELPRVQ
I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ
S Y=0
SELPRVQ Q (Y)
;
SELDX(DX) ;
N Y S Y=1
I PDIAG=1 G SELDXQ
S DIC="^ICD9(",DIC(0)="XMS",X=DX_" " ;SD/529
D ^DIC K DIC I Y<0 S Y=0 G SELDXQ
I $D(PDIAG($P(Y,U))) G SELDXQ
S Y=0
SELDXQ Q (Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMODO3 4492 printed Oct 16, 2024@18:48:32 Page 2
SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ;05 Oct 98 8:44 PM
+1 ;;5.3;Scheduling;**11,25,46,49,159,529,586**;Aug 13, 1993;Build 28
+2 QUIT
REPORT ;
+1 IF '$DATA(^TMP("SDRPT",$JOB))
DO NOREP
GOTO EXIT
START ;
+1 NEW SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK
+2 SET (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)=""
SET (PAGE,QFLAG,SUBCNT)=0
+3 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+4 FOR
SET SDIV=$ORDER(^TMP("SDRPT",$JOB,SDIV))
if SDIV=""
QUIT
Begin DoDot:1
+5 IF SDIV'=SDVC
SET SUBX=$$SUBCNT(SUB1,SUBX)
SET SDFIN='$$HDR(SDIV)
if SDFIN
QUIT
SET SDVC=SDIV
+6 SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP("SDRPT",$JOB,SDIV,SUB1))
if SUB1=""
QUIT
Begin DoDot:2
+7 IF SUBX'=SUB1
SET SUBX=$$SUBCNT(SUB1,SUBX)
+8 IF SORT1=4!(SORT1=5)
IF SUBX]""
IF SUBX'=SUB1
SET SDFIN='$$HDR(SDIV)
+9 SET SUB2=""
FOR
SET SUB2=$ORDER(^TMP("SDRPT",$JOB,SDIV,SUB1,SUB2))
if SUB2=""
QUIT
Begin DoDot:3
+10 SET OEN=0
FOR
SET OEN=$ORDER(^TMP("SDRPT",$JOB,SDIV,SUB1,SUB2,OEN))
if 'OEN
QUIT
SET SUBCNT=SUBCNT+1
SET SDCHECK=""
Begin DoDot:4
+11 SET I=0
FOR
SET I=$ORDER(^TMP("SDRPT",$JOB,SDIV,SUB1,SUB2,OEN,I))
if 'I
QUIT
SET SDFIN='$$PRNT(I)
if SDFIN
QUIT
End DoDot:4
if SDFIN
QUIT
End DoDot:3
if SDFIN
QUIT
End DoDot:2
if SDFIN
QUIT
End DoDot:1
if SDFIN
QUIT
+12 SET SUBX=$$SUBCNT(SUB1,SUBX)
EXIT ;
+1 KILL QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$JOB),SUBCNT,SUBX
+2 QUIT
+3 ;
SUBCNT(SB1,SB1P) ;
+1 IF SB1P']""!(SUBCNT'>0)
GOTO SUBCNTQ
+2 WRITE !,SUBCNT," ",$SELECT(SORT2=1!(SORT2=2):"Primary "_$PIECE($TEXT(SORT+SORT2^SDAMODO1),";;",2),1:$PIECE($TEXT(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$SELECT(SORT1=1!(SORT1=3):$PIECE(SB1P,"^"),SORT1=5:$PIECE(...
... $GET(^DIC(40.7,SB1P,0)),U),1:SB1P),!!
+3 SET SUBCNT=0
SUBCNTQ QUIT (SB1)
+1 ;
PRNT(I) ;
+1 NEW Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID
+2 SET SDATA=(^TMP("SDRPT",$JOB,SDIV,SUB1,SUB2,OEN,I,0))
+3 SET XX=""
FOR
SET XX=$ORDER(^TMP("SDRPT",$JOB,SDIV,SUB1,SUB2,OEN,I,"PRV",XX))
if 'XX
QUIT
SET SPRV(XX)=""
+4 SET XX=""
FOR
SET XX=$ORDER(^TMP("SDRPT",$JOB,SDIV,SUB1,SUB2,OEN,I,"DX",XX))
if XX=""
QUIT
SET SDX(XX)=""
+5 IF SORT1=1
IF '$$SELPRV(SUB1)
SET Y=1
GOTO PRNTQ
+6 IF SORT1=2
IF '$$SELDX(SUB1)
SET Y=1
GOTO PRNTQ
+7 IF $Y+5>IOSL
SET Y='$$HDR(SDIV)
if Y
GOTO PRNTQ
LINE1 ;
+1 SET SDSID=$PIECE($GET(SDATA),U,2)
+2 WRITE !,$PIECE(^DPT($PIECE($GET(SDATA),U),0),U)_" "_$PIECE(SDSID,"-",3)
+3 if SDCHECK=""
SET SDCHECK=SDSID
IF SDSID'=SDCHECK
SET SUBCNT=SUBCNT+1
+4 ; modified to drop seconds
WRITE ?32,$PIECE($$FMTE^XLFDT(OEN,1),":",1,2)
+5 WRITE ?55,$EXTRACT($PIECE(SDATA,U,3),1,25)
+6 WRITE ?90,$SELECT(+$PIECE(SDATA,U,5)>0:$PIECE(^VA(200,+$PIECE(SDATA,U,5),0),U),1:$PIECE(SDATA,U,5))
+7 WRITE ?117,$PIECE(SDATA,U,6)
LINE2 ;
+1 SET SCODE=$PIECE(SDATA,U,4)
+2 WRITE !?56,$PIECE($GET(^DIC(40.7,+SCODE,0)),U,2),"/",$PIECE($GET(^DIC(40.7,+SCODE,0)),U)
+3 SET SDPRX=""
SET SDPRX=$ORDER(SPRV(SDPRX))
IF $DATA(SDPRX)
IF SORT1'=1
WRITE ?90,$SELECT(+SDPRX>0:$PIECE(^VA(200,SDPRX,0),U),1:"")
+4 SET SDDX1=""
SET SDDX1=$ORDER(SDX(SDDX1))
IF $DATA(SDDX1)
IF SORT1'=2
WRITE ?117,SDDX1
+5 SET SDONE=0
+6 FOR XX=1:1
Begin DoDot:1
+7 IF SDDX1'=""
SET SDDX1=$ORDER(SDX(SDDX1))
+8 IF SDPRX'=""
SET SDPRX=$ORDER(SPRV(SDPRX))
+9 IF SDPRX']""&(SDDX1']"")
SET SDONE=1
QUIT
+10 IF $Y+5>IOSL
SET SDONE='$$HDR(SDIV)
if SDONE
QUIT
+11 WRITE !
+12 IF $DATA(SDPRX)
IF SORT1'=1
WRITE ?90,$SELECT(+SDPRX>0:$PIECE(^VA(200,SDPRX,0),U),1:"")
+13 IF $DATA(SDDX1)
IF SORT1'=2
WRITE ?117,SDDX1
End DoDot:1
if SDONE
QUIT
+14 SET Y=1
PRNTQ if QFLAG
SET Y=0
QUIT (Y)
+1 ;
HDR(SDIV) ;
+1 NEW Y
+2 SET Y=0
+3 IF SDVC'=""
IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+4 KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue or '^' to exit"
+5 SET DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen"
SET DIR("?")="The '^' key will exit the listing."
+6 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET QFLAG=1
QUIT
+7 WRITE @IOF
End DoDot:1
if QFLAG
GOTO HDRQ
+8 SET PAGE=PAGE+1
+9 IF $EXTRACT(IOST,1,2)'="C-"
IF SDVC'=""
WRITE @IOF
+10 WRITE !!,"Provider/Diagnosis Encounter Report sorted by ",$PIECE($TEXT(SORT+SORT1^SDAMODO1),";;",2)," and ",$PIECE($TEXT(SORT+SORT2^SDAMODO1),";;",2)
+11 WRITE ?(IOM-40),"Report Date: ",$PIECE($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE
+12 WRITE !,"Inclusion Dates: ",$PIECE($$FMTE^XLFDT(SDBEG,1),"@")," to ",$PIECE($$FMTE^XLFDT(SDEND,1),"@")
+13 WRITE !,"Division: ",$PIECE($GET(^DG(40.8,SDIV,0)),U)
+14 ; SSA ICD-10
+15 WRITE !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX "_$SELECT(SDBEG<ICD10IMPDT:"(ICD9)",1:"(ICD10)")_" CODE"
+16 WRITE !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"---------------"
+17 SET Y=1
HDRQ QUIT (Y)
+1 ;
NOREP ;
+1 WRITE !!,"Provider/Diagnosis Report sorted by ",$PIECE($TEXT(SORT+SORT1^SDAMODO1),";;",2)," and ",$PIECE($TEXT(SORT+SORT2^SDAMODO1),";;",2)
+2 WRITE ?(IOM-40),"Report Date: ",$PIECE($$NOW^VALM1,"@")
+3 WRITE !,"Inclusion Dates: ",$PIECE($$FMTE^XLFDT(SDBEG,1),"@")," to ",$PIECE($$FMTE^XLFDT(SDEND,1),"@")
+4 WRITE !!,"No data found matching sort parameters"
+5 QUIT
+6 ;
SELPRV(PRV) ;
+1 NEW Y
SET Y=1
+2 IF PROVDR=1
GOTO SELPRVQ
+3 IF $DATA(PROVDR($PIECE(PRV,"^",2)))
GOTO SELPRVQ
+4 SET Y=0
SELPRVQ QUIT (Y)
+1 ;
SELDX(DX) ;
+1 NEW Y
SET Y=1
+2 IF PDIAG=1
GOTO SELDXQ
+3 ;SD/529
SET DIC="^ICD9("
SET DIC(0)="XMS"
SET X=DX_" "
+4 DO ^DIC
KILL DIC
IF Y<0
SET Y=0
GOTO SELDXQ
+5 IF $DATA(PDIAG($PIECE(Y,U)))
GOTO SELDXQ
+6 SET Y=0
SELDXQ QUIT (Y)
