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

SDWLROF.m

Go to the documentation of this file.
  1. SDWLROF ;;IOFO BAY PINES/TEH - WAIT LIST OVERDUE REPORT 1;06/12/2002 ; 29 Aug 2002 2:54 PM
  1. ;;5.3;scheduling;**263,414,1015**;AUG 13 1993;Build 21
  1. ;
  1. ;
  1. ;******************************************************************
  1. ; CHANGE LOG
  1. ;
  1. ; DATE PATCH DESCRIPTION
  1. ; ---- ----- -----------
  1. ;
  1. ;
  1. ;
  1. ;
  1. EN D INIT
  1. I $$S^%ZTLOAD G END
  1. D SORT
  1. I $$S^%ZTLOAD G END
  1. D PRINT
  1. I $$S^%ZTLOAD G END
  1. K ^TMP("SDWLQOF",$J)
  1. Q
  1. INIT ;Initialize variables
  1. ;
  1. I $D(CT1) S SDWLCT1=CT1
  1. I $D(CT2) S SDWLCT2=CT2
  1. I $D(DATE) S SDWLDATE=DATE
  1. I $D(FORM) S SDWLFORM=FORM
  1. I $D(INS) S SDWLINS=INS
  1. S SDWLPG=0
  1. I $D(ZTSAVE) D
  1. .F SDWLI="CT1","CT2","FORM","INS" S SDWL="SDWL"_SDWLI,@SDWL=$G(ZTSAVE(SDWLI))
  1. I SDWLINS="ALL" S SDWLIN("ALL")=""
  1. S SDWLTXP=$P(SDWLCT1,U,3),SDWLF=$P(SDWLCT1,U,2)
  1. I SDWLINS'="ALL" F SDWLI=1:1 S SDWLIN=$P($P(SDWLINS,";",SDWLI),U,1) Q:SDWLIN="" S SDWLIN(SDWLIN)="",^TMP("SDWLQOF",$J,SDWLIN)=0
  1. I SDWLCT2'="ALL" F SDWLI=1:1 S SDWLCL=$P($P(SDWLCT2,";",SDWLI),U,1) Q:SDWLCL="" S SDWLCT2(SDWLCL)=""
  1. D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
  1. Q
  1. SORT ;Sort Records
  1. K ^TMP("SDWLROF",$J)
  1. S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D
  1. .S SDWLX=$G(^SDWL(409.3,SDWLDA,0)),SDWLERR=0,SDWLDFN=+SDWLX I 'SDWLDFN Q
  1. .;-Check for Institution Sort
  1. .I SDWLINS'="ALL" D
  1. ..I '$D(SDWLIN(+$P(SDWLX,U,3))) S SDWLERR=1
  1. .;-Check for Date Range Compliance
  1. .I $P(SDWLX,U,16)'<DT,$P(SDWLX,U,16)'=DT S SDWLERR=2
  1. .S SDWLTYP=$P(SDWLCT1,U,1),SDWLTYPE=$S(SDWLTYP="C":+$P(SDWLX,U,9),1:+$P(SDWLX,U,8)) I SDWLTYPE=""!('SDWLTYPE) S SDWLERR=7 Q
  1. .I SDWLCT2'="ALL" D
  1. ..I '$D(SDWLCT2(SDWLTYPE)) S SDWLERR=3
  1. .I SDWLTYP="" S SDWLERR=4
  1. .I $P(SDWLX,U,17)["C" S SDWLERR=6
  1. .Q:SDWLERR D
  1. ..S SDWLSCC=2,DFN=SDWLDFN D ELIG^VADPT I $D(VAEL(3)) S SDWLSCN=$P(VAEL(3),U,2) I SDWLSCN>49 S SDWLSCC=1
  1. ..S ^TMP("SDWLROF",$J,+$P(SDWLX,U,3),SDWLTYPE,SDWLSCC,SDWLDA)=""
  1. ..S SDWLCNT=SDWLCNT+1,^TMP("SDWLROF",$J,+$P(SDWLX,U,3))=SDWLCNT
  1. Q
  1. PRINT ;Print Report
  1. D HD S SDWLCNT=0 I '$D(^TMP("SDWLROF",$J)) W !!,?80-$L("*** No Patient Records to Report ***")\2,"*** No Patient Records to Report ***" Q
  1. S SDWLA="" F S SDWLA=$O(^TMP("SDWLROF",$J,SDWLA)) G END:$$S^%ZTLOAD Q:SDWLA="" D Q:$D(DUOUT)
  1. .D LINE W !!,"Institution: " S X=$$EXTERNAL^DILFD(409.3,2,,SDWLA) W X I '$G(^TMP("SDWLROF",$J,SDWLA)) W !!,"*** No Patient Records to Report ***"
  1. .S SDWLB="" F S SDWLB=$O(^TMP("SDWLROF",$J,SDWLA,SDWLB)) Q:SDWLB="" D Q:$D(DUOUT)
  1. ..W !!,"Clinic/Service: " S X=$$EXTERNAL^DILFD(409.3,SDWLTXP,,SDWLB) W X,! Q:$D(DUOUT)
  1. ..S SDWLC="" F S SDWLC=$O(^TMP("SDWLROF",$J,SDWLA,SDWLB,SDWLC)) Q:SDWLC="" D Q:$D(DUOUT)
  1. ...S SDWLD="" F S SDWLD=$O(^TMP("SDWLROF",$J,SDWLA,SDWLB,SDWLC,SDWLD)) Q:SDWLD="" D Q:$D(DUOUT)
  1. ....S (DFN,SDWLDFN)=$P($G(^SDWL(409.3,SDWLD,0)),U,1) D 1^VADPT,DEM^VADPT,ELIG^VADPT,ADD^VADPT
  1. ....S SDWLELIG=$P(VAEL(1),U,2)
  1. ....S SDWLNAM=VADM(1),SDWLSSN=VA("BID")
  1. ....S SDWLDEAD=1
  1. ....S SDWLAPTD=$P(^SDWL(409.3,SDWLD,0),U,16),SDWLCOM=$P(^SDWL(409.3,SDWLD,0),U,18)
  1. ....S SDWLRBY=$P(^SDWL(409.3,SDWLD,0),U,12),SDWLRPV=$P(^SDWL(409.3,SDWLD,0),U,13)
  1. ....S SDWLPH=$G(VAPA(8))
  1. ....I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
  1. ....W !!,SDWLNAM
  1. ....W ?35,SDWLSSN I SDWLAPTD'="" W ?50,"Desired Date: ",SDWLAPTD
  1. ....W !,"Primary Eligibility: ",SDWLELIG
  1. ....W !,"Comments: ",SDWLCOM,!
  1. ....I SDWLRBY W !,"Requested by: ",$$EXTERNAL^DILFD(409.3,11,,SDWLRBY)
  1. ....I SDWLRPV W ?35,"Requesting Provider: " S X=$$EXTERNAL^DILFD(409.3,12,,SDWLRPV) W X
  1. ....W !,"Telephone (Home): ",$P(SDWLPH,U,1) I $P(SDWLPH,U,2) W !,?10,"(Work): ",$P(SDWLPH,U,2)
  1. ....W !,"*****"
  1. ....I $D(SDWLSPT) S DIR(0)="E" D ^DIR I X["^" S DUOUT=1 Q
  1. ....I '$D(SDWLSPT),'$D(DUOUT),$Y>(IOSL-5) D HD
  1. ....K VAEL,VADM,VA,VAPA
  1. W !!,"** End of Report **"
  1. Q
  1. LINE ;Draw Line
  1. W !,"_______________________________________________________________________________"
  1. Q
  1. HD ;Header
  1. W:$D(IOF) @IOF W !,SDWLDTP,?80-$L("Appt Wait List Overdue Report")\2,"Appt Wait List Overdue Report"
  1. S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD S SDWLPG=SDWLPG+1 W ?72,"Page: ",SDWLPG
  1. W !!,?30,"Institution: " I SDWLINS="ALL" D
  1. .W ?45,SDWLINS
  1. F I=1:1 S X=$P($P(SDWLINS,";",I),"^",2) Q:X="" W:I>1 ! W ?45,X
  1. S X=$P(SDWLCT2,U,2)
  1. W !?26,"Report Category: ",$S($P(SDWLCT1,U,1)="C":"CLINIC",1:"SPECIALTY") I X="ALL" W " ALL"
  1. I X'="ALL" D
  1. .F I=1:1 S X=$P($P(SDWLCT2,";",I),"^",2) Q:X="" W !,?45,$$EXTERNAL^DILFD(SDWLF,.01,,X)
  1. S X=$G(SDWLFORM) W !,?28,"Output Format: ",$S(SDWLFORM="S":"Summary",1:"Detailed")
  1. Q
  1. END K SDWL,SDWLA,SDWLAPTD,SDWLB,SDWLBD,SDWLBDT,SDWLC,SDWLCAT,SDWLCNT,SDWLCOM,SDWLCT1,SDWLCT2,SDWLCTX,SDWLD
  1. K SDLWDA,SDLWDEAD,SDWLDFN,SDWLE,SDWLEDT,SDWLELIG,SDWLERR,SDWLF,SDWLFD,SDWLI,SDWLIN,SDWLINS,SDWLINST
  1. K SDWLNAM,SDWLPD,SDWLPG,SDWLPH,SDWLPROM,SDWLRBY,SDWLPRV,SDWLSCC,SDWLSPT,SDWLSSN,SDWLTAG,SDLTK,SDWLTXP
  1. K SDWLTYP,SDWLTYPE,SDWLX,CT1,CT2,DATE,I,INS,OPEN,FORM
  1. Q