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

SDLT.m

Go to the documentation of this file.
  1. SDLT ;ALB/LDB,GXT - CANCELLATION LETTERS ;17 JUL 2018
  1. ;;5.3;Scheduling;**185,213,281,330,398,523,441,555,622,641,680,705**;Aug 13, 1993;Build 11
  1. ;;PER VHA DIRECTIVE 2004-038, DO NOT MODIFY THIS ROUTINE
  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. ; 12/2/03 SD*5.3*330 LUNDEN Remove form feed from PRT+0
  1. ; 01/21/16 SD*5.3*641 HSI Print 1st piece of 99 node
  1. ; 11/27/17 SD*5.3*680 JACKSON Remove gender implications
  1. ; 06/13/18 SD*5.3*705 THOMAS Add blank line between appointments in
  1. ; letters
  1. ;**************************************************************************
  1. ;
  1. N Z0,X
  1. ;WRITE GREETING AND OPENING TEXT OF LETTER
  1. PRT S DFN=$P(A,U,1) ;SD*523
  1. I $D(SDNOSH) I $D(^DPT(DFN,.1)) S POP=1 Q:POP ;SD/523
  1. S Y=DT D DTS^SDUTL
  1. I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1
  1. K SDFIRST
  1. ;S SDFIRST=0
  1. W !,?65,Y,!,?65,$$LAST4(A),!!!!
  1. I 'SDFORM W !!!!! D ADDR W !!!!
  1. W1 W !,"Dear " ;,$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ") SD*5.3*680
  1. N DPTNAME
  1. S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_","
  1. S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,","
  1. 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
  1. D ^DIWW K ^UTILITY($J,"W") Q
  1. WRAPP ;WRITE APPOINTMENT INFORMATION
  1. N B
  1. ; SD*5.3*622 - re-arrange display of clinic name
  1. ;S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM
  1. S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=" Clinic: "_SDCL D FORM ; SD*5.3*622 end changes
  1. ;
  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. ; SD*5.3*622 - add more detail for appointment and format it
  1. FORM 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))
  1. ; Add blank line between appointments in letters - Done with patch SD*5.3*705
  1. I $$ADLIN,'$D(B) W !
  1. W:'$D(B) !?5,"Date/Time: ",?17,DOW,?$L(DOW)+19,$J(SDDAT,12)
  1. I '$D(B),$D(SDC) W ?22,$J(SDT0,9),!?5,SDCL
  1. ; get default provider if defined for a given clinic, print it on the
  1. ; letter only if we have a YES on file, same for clinic location
  1. ; skip printing the provider label if the field is empty in file #44
  1. N J,SDLOC,SDPROV,SDPRNM,SDTEL,SDTELEXT
  1. S SDLOC=$P($G(^SC(+SDC,0)),"^",11) ; physical location of the clinic
  1. S SDTEL=$G(^SC(+SDC,99)) ; telephone number of clinic
  1. S SDTELEXT="" I SDTEL]"",$G(^SC(+SDC,99.1))]"" D
  1. .S SDTELEXT=^SC(+SDC,99.1) ; telephone ext of clinic
  1. ; get default provider, if any
  1. F J=0:0 S J=$O(^SC(+SDC,"PR",J)) Q:'J>0 I $P($G(^SC(+SDC,"PR",J,0)),U,2)=1 S SDPROV=+$P(^SC(+SDC,"PR",J,0),U,1)
  1. I $D(SDC),'$D(B),$P($G(^VA(407.5,SDLET,3)),U,2)="Y" D
  1. .W:SDLOC]"" !?6,"Location: "_SDLOC
  1. I $D(SDC),'$D(B),SDTEL]"" D
  1. .W !?5,"Telephone: ",$P(SDTEL,U)
  1. .W:SDTELEXT]"" " Telephone Ext.: ",SDTELEXT
  1. I $D(SDPROV) D
  1. .I $D(SDC),SDPROV>0 S SDPRNM=$P(^VA(200,SDPROV,0),U,1)
  1. .I $D(SDC),'$D(B),$P($G(^VA(407.5,SDLET,3)),U,1)="Y" W:SDPRNM]"" !?6,"Provider: "_$G(SDPRNM)
  1. ; call handler for LAB, XRAY, and EKG tests
  1. I $D(B) D TST
  1. I $D(SDLT)&($Y>(IOSL-8)) W @IOF
  1. ; SD*5.3*622 end changes
  1. Q
  1. REST ;WRITE THE REMAINDER OF LETTER
  1. N Z5,I,X
  1. 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
  1. D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM
  1. F I=$Y:1:IOSL-12 W !
  1. D ADDR Q
  1. ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN)
  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 D
  1. .;CHANGE STATE TO ABBR.
  1. .N SDIENS,X
  1. .I $D(VAPA(5)) S SDIENS=+VAPA(5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(VAPA(5),U,2)=X
  1. .I $D(VAPA(17)) S SDIENS=+VAPA(17)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(VAPA(17),U,2)=X
  1. .K SDIENS Q
  1. N SDCCACT1,SDCCACT2,LL
  1. S SDCCACT1=VAPA(12),SDCCACT2=$P($G(VAPA(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:3 W:VAPA(LL)]"" !,?12,VAPA(LL)
  1. .;if country is blank display as USA
  1. .I (VAPA(25)="")!($P(VAPA(25),"^",2)="UNITED STATES") D ;display city,state,zip
  1. ..W !,?12,VAPA(4)_" "_$P(VAPA(5),U,2)_" "_$P(VAPA(11),U,2)
  1. .E D ;display postal code,city,province
  1. ..W !,?12,VAPA(24)_" "_VAPA(4)_" "_VAPA(23)
  1. .W:($P(VAPA(25),"^",2)'="UNITED STATES") !,?12,$P(VAPA(25),U,2) ;display country
  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:15 W:VAPA(LL)]"" !,?12,VAPA(LL)
  1. .I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D
  1. ..W !,?12,VAPA(16)_" "_$P(VAPA(17),U,2)_" "_$P(VAPA(18),U,2)
  1. .E D
  1. ..W !,?12,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
  1. .W:($P(VAPA(28),"^",2)'="UNITED STATES") !?12,$P(VAPA(28),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)
  1. ;
  1. BADADD ;Print patients with a Bad Address Indicator
  1. I '$D(^TMP($J,"BADADD")) Q
  1. N SDHDR,SDHDR1
  1. W @IOF,$TR($J("",IOM)," ","*")
  1. S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,!
  1. S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
  1. W !,"Last 4",!,"of SSN",?10,"Patient Name",!
  1. W $TR($J("",IOM)," ","*")
  1. N SDNAM,SDDFN
  1. S SDNAM="" F S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM="" D
  1. . S SDDFN=0 F S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN D
  1. . . W !,$$LAST4(SDDFN),?10,SDNAM
  1. W !!,SDHDR1
  1. Q
  1. ;
  1. TST ; SD*5.3*622 - handle scheduled tests
  1. W !
  1. W:($L(SDCL)=3&($E(SDCL,1,3)="LAB")) ?1,SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)
  1. W:($L(SDCL)=4&($E(SDCL,1,4)="XRAY")) SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)
  1. W:($L(SDCL)=3&($E(SDCL,1,3)="EKG")) ?1,SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)
  1. Q ; SD*5.3*622 - end of changes
  1. ;
  1. ADLIN() ;
  1. ; This API is checked to determine if the "ENABLE BLANK LINE?" (#1.1)
  1. ; field in the SCHEDULING PARAMETERS (404.91) file is set to "YES"
  1. ; (internal value 1).
  1. ; Added with patch SD*5.3*705
  1. N DIQ,DIC,DA,DR
  1. S DIQ(0)="I",DIC=404.91,DA=1,DR="1.1"
  1. Q +$$GET1^DIQ(DIC,DA_",",DR,"I")