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