source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDAMODO3.m@ 1742

SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98  8:44 PM
 ;;5.3;Scheduling;**11,25,46,49,159,529**;Aug 13, 1993;Build 3
 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)
 W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX 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)