- 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 Feb 19, 2025@00:14:24 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)
