- 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
