SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003
;;5.3;PIMS;**185,213,281,330,398,523,441,1007,1015,1016**;JUN 30, 2012;Build 20
;
;**************************************************************************
; MODIFICATIONS
;
; DATE PATCH DEVELOPER DESCRIPTION OF CHANGES
; -------- ---------- --------- ----------------------------------------
; 02/14/03 SD*5.3*281 SAUNDERS Print letters to confidential address if
; requested
; 12/2/03 SD*5.3*330 LUNDEN Remove form feed from PRT+0
;
;**************************************************************************
;
;IHS/ITSC/LJF 10/02/2003 moved IHS mods to BSDLT; added calls here
;cmi/anch/maw 11/22/2006 PATCH 1007 added modifications for item 1007.12 to put ancillary items in time order
;
D PRT^BSDLT Q ;IHS/ITSC/LJF 10/02/2003
N Z0,X
;WRITE GREETING AND OPENING TEXT OF LETTER
PRT S DFN=$P(A,U,1) ;SD*523
I $D(SDNOSH) I $D(^DPT(DFN,.1)) S POP=1 Q:POP ;SD/523
S Y=DT D DTS^SDUTL
I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1
K SDFIRST
;S SDFIRST=0
W !,?65,Y,!,?65,$$LAST4(A),!!!!
I 'SDFORM W !!!!! D ADDR W !!!!
W1 W !,"Dear ",$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ")
N DPTNAME
S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_","
S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,","
W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0 S X=^(Z0,0) D ^DIWP
D ^DIWW K ^UTILITY($J,"W") Q
WRAPP ;WRITE APPOINTMENT INFORMATION
S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM
N B
;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
;cmi/anch/maw 11/11/2006 here is where we will put the date stamp in order for ancillaries item 1007.12 patch 1007
;first lets split the below line
;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 ;cmi/anch/maw orig line item 1007.12 patch 1007
;cmi/anch/maw 11/11/2006 added below lines to put ancillaries in date/time order item 1007.12 patch 1007
S SDX1=$S($D(SDX):SDX,1:X) ;cmi/anch/maw 11/11/2006 split above line item 1007.12 patch 1007
S:$D(SDS) S=SDS ;cmi/anch/maw 11/11/2006 split above line item 1007.12 patch 1007
I $G(S) D ;cmi/anch/maw 11/11/2006 split above line item 1007.12 patch 1007
. N BSDARY
. F B=3,4,5 I $P(S,"^",B)]"" D
.. S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B)
.. Q:'$G(SDX)
.. S BSDARY(SDX)=SDCL
. N BSDLP
. S BSDLP=0 F S BSDLP=$O(BSDARY(BSDLP)) Q:'BSDLP D
.. S SDX=BSDLP,SDCL=$G(BSDARY(BSDLP))
.. D FORM
;cmi/anch/maw 11/11/2006 end of modifications item 1007.12 patch 1007
S (SDX,X)=SDX1 Q
FORM D FORM^BSDLT Q ;IHS/ITSC/LJF 10/02/2003
S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=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 !?4,DOW,?14,$J(SDDAT,12)
W ?27,$J(SDT0,8)," ",SDCL I $D(SDLT)&($Y>(IOSL-8)) W @IOF
Q
REST ;WRITE THE REMAINDER OF LETTER
D REST^BSDLT Q ;IHS/ITSC/LJF 10/02/2003
N Z5,I,X
I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0 S X=^(Z5,0) D ^DIWP
D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM
F I=$Y:1:IOSL-12 W !
D ADDR Q
ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN)
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 D
.;CHANGE STATE TO ABBR.
.N SDIENS,X
.I $D(VAPA(5)) S SDIENS=+VAPA(5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(VAPA(5),U,2)=X
.I $D(VAPA(17)) S SDIENS=+VAPA(17)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(VAPA(17),U,2)=X
.K SDIENS Q
N SDCCACT1,SDCCACT2,LL
S SDCCACT1=VAPA(12),SDCCACT2=$P($G(VAPA(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:3 W:VAPA(LL)]"" !,?12,VAPA(LL)
.;if country is blank display as USA
.I (VAPA(25)="")!($P(VAPA(25),"^",2)="UNITED STATES") D ;display city,state,zip
..W !,?12,VAPA(4)_" "_$P(VAPA(5),U,2)_" "_$P(VAPA(11),U,2)
.E D ;display postal code,city,province
..W !,?12,VAPA(24)_" "_VAPA(4)_" "_VAPA(23)
.W:($P(VAPA(25),"^",2)'="UNITED STATES") !,?12,$P(VAPA(25),U,2) ;display country
;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:15 W:VAPA(LL)]"" !,?12,VAPA(LL)
.I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D
..W !,?12,VAPA(16)_" "_$P(VAPA(17),U,2)_" "_$P(VAPA(18),U,2)
.E D
..W !,?12,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
.W:($P(VAPA(28),"^",2)'="UNITED STATES") !?12,$P(VAPA(28),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)
;
BADADD ;Print patients with a Bad Address Indicator
I '$D(^TMP($J,"BADADD")) Q
N SDHDR,SDHDR1
W @IOF,$TR($J("",IOM)," ","*")
S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,!
S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
W !,"Last 4",!,"of SSN",?10,"Patient Name",!
W $TR($J("",IOM)," ","*")
N SDNAM,SDDFN
S SDNAM="" F S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM="" D
. S SDDFN=0 F S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN D
. . W !,$$LAST4(SDDFN),?10,SDNAM
W !!,SDHDR1
Q
SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003
+1 ;;5.3;PIMS;**185,213,281,330,398,523,441,1007,1015,1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;**************************************************************************
+4 ; MODIFICATIONS
+5 ;
+6 ; DATE PATCH DEVELOPER DESCRIPTION OF CHANGES
+7 ; -------- ---------- --------- ----------------------------------------
+8 ; 02/14/03 SD*5.3*281 SAUNDERS Print letters to confidential address if
+9 ; requested
+10 ; 12/2/03 SD*5.3*330 LUNDEN Remove form feed from PRT+0
+11 ;
+12 ;**************************************************************************
+13 ;
+14 ;IHS/ITSC/LJF 10/02/2003 moved IHS mods to BSDLT; added calls here
+15 ;cmi/anch/maw 11/22/2006 PATCH 1007 added modifications for item 1007.12 to put ancillary items in time order
+16 ;
+17 ;IHS/ITSC/LJF 10/02/2003
DO PRT^BSDLT
QUIT
+18 NEW Z0,X
+19 ;WRITE GREETING AND OPENING TEXT OF LETTER
PRT ;SD*523
SET DFN=$PIECE(A,U,1)
+1 ;SD/523
IF $DATA(SDNOSH)
IF $DATA(^DPT(DFN,.1))
SET POP=1
IF POP
QUIT
+2 SET Y=DT
DO DTS^SDUTL
+3 ;SD*5.3*330 Form feed only after letter #1
IF +$GET(SDFIRST)=0
WRITE @IOF
+4 KILL SDFIRST
+5 ;S SDFIRST=0
+6 WRITE !,?65,Y,!,?65,$$LAST4(A),!!!!
+7 IF 'SDFORM
WRITE !!!!!
DO ADDR
WRITE !!!!
W1 WRITE !,"Dear ",$SELECT($PIECE(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ")
+1 NEW DPTNAME
+2 SET DPTNAME("FILE")=2
SET DPTNAME("FIELD")=".01"
SET DPTNAME("IENS")=(+A)_","
+3 SET X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M")
WRITE X,","
+4 WRITE !!
KILL ^UTILITY($JOB,"W"),DIWF,DIWR,DIWF
SET DIWL=1
SET DIWF="C80WN"
FOR Z0=0:0
SET Z0=$ORDER(^VA(407.5,SDLET,1,Z0))
IF Z0'>0
QUIT
SET X=^(Z0,0)
DO ^DIWP
+5 DO ^DIWW
KILL ^UTILITY($JOB,"W")
QUIT
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 NEW B
+3 ;S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM
+4 ;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
+5 ;cmi/anch/maw 11/11/2006 here is where we will put the date stamp in order for ancillaries item 1007.12 patch 1007
+6 ;first lets split the below line
+7 ;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 ;cmi/anch/maw orig line item 1007.12 patch 1007
+8 ;cmi/anch/maw 11/11/2006 added below lines to put ancillaries in date/time order item 1007.12 patch 1007
+9 ;cmi/anch/maw 11/11/2006 split above line item 1007.12 patch 1007
SET SDX1=$SELECT($DATA(SDX):SDX,1:X)
+10 ;cmi/anch/maw 11/11/2006 split above line item 1007.12 patch 1007
IF $DATA(SDS)
SET S=SDS
+11 ;cmi/anch/maw 11/11/2006 split above line item 1007.12 patch 1007
IF $GET(S)
Begin DoDot:1
+12 NEW BSDARY
+13 FOR B=3,4,5
IF $PIECE(S,"^",B)]""
Begin DoDot:2
+14 SET SDCL=$SELECT(B=3:"LAB",B=4:"XRAY",1:"EKG")
SET SDX=$PIECE(S,"^",B)
+15 IF '$GET(SDX)
QUIT
+16 SET BSDARY(SDX)=SDCL
End DoDot:2
+17 NEW BSDLP
+18 SET BSDLP=0
FOR
SET BSDLP=$ORDER(BSDARY(BSDLP))
IF 'BSDLP
QUIT
Begin DoDot:2
+19 SET SDX=BSDLP
SET SDCL=$GET(BSDARY(BSDLP))
+20 DO FORM
End DoDot:2
End DoDot:1
+21 ;cmi/anch/maw 11/11/2006 end of modifications item 1007.12 patch 1007
+22 SET (SDX,X)=SDX1
QUIT
FORM ;IHS/ITSC/LJF 10/02/2003
DO FORM^BSDLT
QUIT
+1 IF $DATA(SDX)
SET X=SDX
SET SDHX=X
DO DW^%DTC
SET DOW=X
SET X=SDHX
XECUTE ^DD("FUNC",2,1)
SET SDT0=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 !?4,DOW,?14,$JUSTIFY(SDDAT,12)
+2 WRITE ?27,$JUSTIFY(SDT0,8)," ",SDCL
IF $DATA(SDLT)&($Y>(IOSL-8))
WRITE @IOF
+3 QUIT
REST ;WRITE THE REMAINDER OF LETTER
+1 ;IHS/ITSC/LJF 10/02/2003
DO REST^BSDLT
QUIT
+2 NEW Z5,I,X
+3 IF SDLET
WRITE !?12
KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF
SET DIWL=1
SET DIWF="C80WN"
FOR Z5=0:0
SET Z5=$ORDER(^VA(407.5,SDLET,2,Z5))
IF Z5'>0
QUIT
SET X=^(Z5,0)
DO ^DIWP
+4 DO ^DIWW
KILL ^UTILITY($JOB,"W")
IF 'SDFORM
QUIT
+5 FOR I=$Y:1:IOSL-12
WRITE !
+6 DO ADDR
QUIT
ADDR KILL VAHOW
SET DFN=+A
WRITE !?12,$$FML^DGNFUNC(DFN)
+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
Begin DoDot:1
+4 ;CHANGE STATE TO ABBR.
+5 NEW SDIENS,X
+6 IF $DATA(VAPA(5))
SET SDIENS=+VAPA(5)_","
SET X=$$GET1^DIQ(5,SDIENS,1)
SET $PIECE(VAPA(5),U,2)=X
+7 IF $DATA(VAPA(17))
SET SDIENS=+VAPA(17)_","
SET X=$$GET1^DIQ(5,SDIENS,1)
SET $PIECE(VAPA(17),U,2)=X
+8 KILL SDIENS
QUIT
End DoDot:1
+9 NEW SDCCACT1,SDCCACT2,LL
+10 SET SDCCACT1=VAPA(12)
SET SDCCACT2=$PIECE($GET(VAPA(22,2)),"^",3)
+11 ;if confidential address is not active for scheduling/appointment letters, print to regular address
+12 IF ($GET(SDCCACT1)=0)!($GET(SDCCACT2)'="Y")
Begin DoDot:1
+13 FOR LL=1:1:3
IF VAPA(LL)]""
WRITE !,?12,VAPA(LL)
+14 ;if country is blank display as USA
+15 ;display city,state,zip
IF (VAPA(25)="")!($PIECE(VAPA(25),"^",2)="UNITED STATES")
Begin DoDot:2
+16 WRITE !,?12,VAPA(4)_" "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(11),U,2)
End DoDot:2
+17 ;display postal code,city,province
IF '$TEST
Begin DoDot:2
+18 WRITE !,?12,VAPA(24)_" "_VAPA(4)_" "_VAPA(23)
End DoDot:2
+19 ;display country
IF ($PIECE(VAPA(25),"^",2)'="UNITED STATES")
WRITE !,?12,$PIECE(VAPA(25),U,2)
End DoDot:1
+20 ;if confidential address is active for scheduling/appointment letters, print to confidential address
+21 IF $GET(SDCCACT1)=1
IF $GET(SDCCACT2)="Y"
Begin DoDot:1
+22 FOR LL=13:1:15
IF VAPA(LL)]""
WRITE !,?12,VAPA(LL)
+23 IF (VAPA(28)="")!($PIECE(VAPA(28),"^",2)="UNITED STATES")
Begin DoDot:2
+24 WRITE !,?12,VAPA(16)_" "_$PIECE(VAPA(17),U,2)_" "_$PIECE(VAPA(18),U,2)
End DoDot:2
+25 IF '$TEST
Begin DoDot:2
+26 WRITE !,?12,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
End DoDot:2
+27 IF ($PIECE(VAPA(28),"^",2)'="UNITED STATES")
WRITE !?12,$PIECE(VAPA(28),U,2)
End DoDot:1
+28 WRITE !
DO KVAR^VADPT
QUIT
+29 ;
+30 ;
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)
+4 ;
BADADD ;Print patients with a Bad Address Indicator
+1 IF '$DATA(^TMP($JOB,"BADADD"))
QUIT
+2 NEW SDHDR,SDHDR1
+3 WRITE @IOF,$TRANSLATE($JUSTIFY("",IOM)," ","*")
+4 SET SDHDR="BAD ADDRESS INDICATOR LIST"
WRITE !,?(IOM-$LENGTH(SDHDR)/2),SDHDR,!
+5 SET SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
+6 WRITE !,"Last 4",!,"of SSN",?10,"Patient Name",!
+7 WRITE $TRANSLATE($JUSTIFY("",IOM)," ","*")
+8 NEW SDNAM,SDDFN
+9 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^TMP($JOB,"BADADD",SDNAM))
IF SDNAM=""
QUIT
Begin DoDot:1
+10 SET SDDFN=0
FOR
SET SDDFN=$ORDER(^TMP($JOB,"BADADD",SDNAM,SDDFN))
IF 'SDDFN
QUIT
Begin DoDot:2
+11 WRITE !,$$LAST4(SDDFN),?10,SDNAM
End DoDot:2
End DoDot:1
+12 WRITE !!,SDHDR1
+13 QUIT
