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

BSDLT.m

Go to the documentation of this file.
  1. BSDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003 [ 03/10/2004 10:53 AM ]
  1. ;;5.3;PIMS;**1013**;APR 26, 2002
  1. ;COPY OF SDLT WITH IHS MODS
  1. ;;5.3;Scheduling;**185,213,281**;Aug 13, 1993
  1. ;IHS/ANMC/LJF 8/18/2000 changed SSN to HRCN using VA(PID)
  1. ; added customized salutation
  1. ; 11/24/2000 moved left margin in 5 spaces
  1. ; 11/29/2000 added call to print future appts
  1. ; 3/23/2001 changed X ^DD("FUNC",2,1) to $$TIME^BDGF
  1. ; 11/03/2001 used zip code instead of zip+4
  1. ; 6/05/2002 moved form feed to end of letter
  1. ;ihs/cmi/maw 05/03/2011 PATCH 1013 added storing of patient tracking on letters
  1. ;
  1. ;**************************************************************************
  1. ; MODIFICATIONS
  1. ;
  1. ; DATE PATCH DEVELOPER DESCRIPTION OF CHANGES
  1. ; -------- ---------- --------- ----------------------------------------
  1. ; 02/14/03 SD*5.3*281 SAUNDERS Print letters to confidential address if
  1. ; requested
  1. ;
  1. ;**************************************************************************
  1. ;
  1. ;
  1. ;WRITE GREETING AND OPENING TEXT OF LETTER
  1. PRT ;EP;
  1. ;IHS/ITSC/WAR 3/10/04 Added 'Date Printed' for Pt clarification
  1. ;S Y=DT D DTS^SDUTL W !,?65,Y,!,?65,"#",$$HRCN^BDGF2(+A,DUZ(2)),!!!!
  1. S Y=DT D DTS^SDUTL W !,?51,"Date Printed: ",Y,!,?65,"#",$$HRCN^BDGF2(+A,DUZ(2)),!!!! ;IHS/ANMC/LJF 8/18/2000; 6/5/2002 removed form feed at front (LJF7 6/11/2002)
  1. I 'SDFORM W !!!!! D ADDR W !!!!
  1. W1 ;
  1. W !?5,$$GREETING^BSDU(SDLET,+A) ;IHS/ANMC/LJF 8/18/2000
  1. W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=6,DIWF="C70W" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0 S X=^(Z0,0) D ^DIWP ;IHS/ANMC/LJF 11/24/2000
  1. ;
  1. D ^DIWW K ^UTILITY($J,"W")
  1. D STORE(+A,SDLET,DT) ;ihs/cmi/maw store the letter and date printed
  1. Q
  1. ;
  1. STORE(PAT,LET,D) ;-- lets store the date printed and letter for tracking
  1. Q:'$P($G(^BSDPAR($S($G(DIV):DIV,1:1),0)),U,28) ;quit if the site parameter for tracking letter printing is off
  1. N FDA,FIENS,FERR
  1. S FIENS="+2,"_LET_","
  1. S FDA(407.51,FIENS,.01)=PAT
  1. S FDA(407.51,FIENS,.02)=DT
  1. D UPDATE^DIE("","FDA","FIENS","FERR(1)")
  1. Q
  1. ;
  1. WRAPP ;WRITE APPOINTMENT INFORMATION
  1. S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM
  1. S SDX1=$S($D(SDX):SDX,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM
  1. S (SDX,X)=SDX1 Q
  1. FORM ;EP;
  1. ;IHS/ANMC/LJF 11/24/2000;3/23/2001 see line below
  1. S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX S SDT0=$$TIME^BDGF(X),SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) W !?9,DOW,?19,$J(SDDAT,12)
  1. W ?32,$J(SDT0,8)," ",SDCL ;I $D(SDLT)&($Y>(IOSL-8)) W @IOF ;IHS/ANMC/LJF 11/24/2000
  1. Q
  1. RECALL(CL,P) ;-- get recall information and clinic based on patient and clinic passed in
  1. N RC,CDA
  1. S CDA=0 F S CDA=$O(^BSDWL("AB",P,CL,CDA)) Q:'CDA D
  1. . Q:$P($G(^BSDWL(CL,1,CDA,0)),U,7)
  1. . S RC=$P($G(^BSDWL(CL,1,CDA,0)),U,5)
  1. W !!,?5,"Recall Date: "_$$FMTE^XLFDT($G(RC)),?40,"Clinic/Ward: "_$$GET1^DIQ(44,$P($G(^BSDWL(CL,0)),U),.01)
  1. Q
  1. ;
  1. REST ;EP; WRITE THE REMAINDER OF LETTER
  1. I $G(S1)="C" D FUTURE^BSDLT1(+A,$G(BSDCNT)) K BSDCNT ;IHS/ANMC/LJF 11/29/2000;9/11/2001
  1. I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=6,DIWF="C70W" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0 S X=^(Z5,0) D ^DIWP ;IHS/ANMC/LJF 11/24/2000
  1. D ^DIWW K ^UTILITY($J,"W") I 'SDFORM W @IOF Q ;IHS/ANMC/LJF 6/5/2002 form feed at end of letter (LJF7 6/11/2002)
  1. F I=$Y:1:IOSL-12 W !
  1. D ADDR W @IOF Q ;IHS/ANMC/LJF 6/5/2002 put form feed at end of letter (LJF7 6/11/2002)
  1. ;
  1. ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN) S VAHOW=2
  1. I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")=""
  1. S X1=DT,X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X
  1. D ADD^VADPT
  1. N SDCCACT1,SDCCACT2
  1. S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3)
  1. ;if confidential address is not active for scheduling/appointment letters, print to regular address
  1. I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D
  1. .F LL=1:1:4 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL)
  1. .W:^UTILITY("VAPA",$J,4)']"" ! I ^UTILITY("VAPA",$J,5)]"" W ", ",$P(^UTILITY("VAPA",$J,5),"^",2)
  1. I ^UTILITY("VAPA",$J,6)]"" W " ",^UTILITY("VAPA",$J,6) ;IHS/ANMC/LJF 11/03/2001 zip code; not zip+4
  1. ;if confidential address is active for scheduling/appointment letters, print to confidential address
  1. I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D
  1. .F LL=13:1:16 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL)
  1. .W:^UTILITY("VAPA",$J,16)']"" ! I ^UTILITY("VAPA",$J,17)]"" W ", ",$P(^UTILITY("VAPA",$J,17),"^",2)
  1. .I ^UTILITY("VAPA",$J,18)]"" W " ",$P(^UTILITY("VAPA",$J,18),U,2)
  1. W ! D KVAR^VADPT Q
  1. ;
  1. ;
  1. LAST4(DFN) ;Return patient "last four"
  1. N SDX
  1. S SDX=$G(^DPT(+DFN,0))
  1. Q $E(SDX)_$E($P(SDX,U,9),6,9)