SDECDEV ;ALB/SAT - VISTA SCHEDULING RPCS ;JUN 21, 2017
;;5.3;Scheduling;**627,658,665**;Aug 13, 1993;Build 14
;
Q
;
DEVICE(SDECY) ;EP List of printers
; OUTPUT:
; SDECY(n)=REPORT TEXT
;
N SDECI,FROM,DIR,ARR
S SDECI=0
S SDECY=$NA(^TMP("SDECDEV",$J,"DEVICE")) K @SDECY
S @SDECY@(SDECI)="I00030PRINTER_IEN^T00040PRINTER_NAME"_$C(30)
N CNT,IEN,X,Y,X0,XLOC,XSEC,XTYPE,XSTYPE,XTIME,XOSD,MW,PL,DEV
S FROM="",DIR=1
F S FROM=$O(^%ZIS(1,"B",FROM),DIR),IEN=0 Q:FROM="" D
.F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D
..Q:$D(ARR(IEN))
..S ARR(IEN)=""
..S DEV="",X0=$G(^%ZIS(1,IEN,0)),XLOC=$P($G(^(1)),U),XOSD=+$G(^(90)),MW=$G(^(91)),XSEC=$G(^(95)),XSTYPE=+$G(^("SUBTYPE")),XTIME=$P($G(^("TIME")),U),XTYPE=$P($G(^("TYPE")),U)
..Q:$E($G(^%ZIS(2,XSTYPE,0)))'="P" ; Printers only
..Q:"^TRM^HG^CHAN^OTH^"'[(U_XTYPE_U)
..Q:$P(X0,U,2)="0"!($P(X0,U,12)=2) ; Queuing allowed
..I XOSD,XOSD'>DT Q ; Out of Service
..I $L(XTIME) D Q:'$L(XTIME) ; Prohibited Times
...S Y=$P($H,",",2),Y=Y\60#60+(Y\3600*100),X=$P(XTIME,"-",2)
...S:X'<XTIME&(Y'>X&(Y'<XTIME))!(X<XTIME&(Y'<XTIME!(Y'>X))) XTIME=""
..I $L(XSEC),$G(DUZ(0))'="@",$TR(XSEC,$G(DUZ(0)))=XSEC Q
..S PL=$P(MW,U,3),MW=$P(MW,U),X=$G(^%ZIS(2,XSTYPE,1))
..S:'MW MW=$P(X,U)
..S:'PL PL=$P(X,U,3)
..S X=$P(X0,U)
..Q:$E(X,1,4)["NULL"
..S:X'=FROM X=FROM_" <"_X_">"
..S SDECI=SDECI+1,@SDECY@(SDECI)=IEN_U_$P(X0,U)_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
;
DEV(RET,TYPE,MAX,LSUB,PARTIAL) ;GET devices of the given type ;alb/sat 658
;INPUT:
; TYPE - (optional) Device type
; A:All Printers (default)
; P:Printers only on current namespace
; C:Complete Device Listing (not supported)
; D:Devices only on current namespace (not supported)
; N:New Format for Device Specification (not supported)
; E:Extended Help (not supported)
; MAX - (optional) Max records to return
; LSUB - (optional) Last subscripts used to continue from last call
; Use LASTSUB (return piece 3) from previous call
; PARTIAL - (optional) - partial device name lookup
;RETURN:
; DIEN = Device IEN pointer to DEVICE file (#3.5) OR -1 if error
; DNAME = Device Name OR message if error
; LOCT = Location of Terminal text
; LASTSUB = Last subscripts to continue with next call
; Pass in as LSUB input
N SDCNT,SDSUB,SDTMP
S SDSUB=""
S SDCNT=0
S RET=$NA(^TMP("SDECDEV",$J,"DEV"))
K @RET
S SDTMP="T00030DIEN^T00030DNAME^T00050LOCT^T00100LASTSUB"
S @RET@(0)=SDTMP_$C(30)
;validate TYPE
S TYPE=$G(TYPE)
I TYPE="" S TYPE="A"
I "AP"'[TYPE S @RET@(1)="-1^Invalid Device Type - "_TYPE_"."_$C(30,31) Q ;"APCDNE"
;validate MAX
S MAX=$G(MAX)
I MAX'="",MAX'=+MAX S @RET@(1)="-1^Invalid max records value - "_MAX_"."_$C(30,31) Q
S:MAX="" MAX=9999999
;validate LSUB
S LSUB=$G(LSUB)
;validate PARTIAL
S PARTIAL=$G(PARTIAL)
;
D @TYPE
;
I SDSUB'="" S SDTMP=$P(@RET@(SDCNT),$C(30),1),$P(SDTMP,U,4)=SDSUB,@RET@(SDCNT)=SDTMP_$C(30)
S @RET@(SDCNT)=@RET@(SDCNT)_$C(31)
Q
A ;All Printers
N DN,SDID
S DN=$S($P(LSUB,"|",1)'="":$P(LSUB,"|",1),PARTIAL'="":$$GETSUB^SDECU(PARTIAL),1:"")
F S DN=$O(^%ZIS(1,"B",DN)) Q:DN="" Q:(PARTIAL'="")&(DN'[PARTIAL) D I SDCNT>MAX S SDSUB=DN_"|"_SDID Q
.S SDID=$S($P(LSUB,"|",2)'="":$P(LSUB,"|",2),1:0)
.S LSUB=""
.F S SDID=$O(^%ZIS(1,"B",DN,SDID)) Q:SDID="" D I SDCNT>MAX S SDSUB=DN_"|"_SDID Q
..Q:'$D(^%ZIS(1,SDID,0)) ;existence check
..Q:$P($G(^%ZIS(2,+$G(^%ZIS(1,SDID,"SUBTYPE")),0)),U)'?1"P".E ;subtype check
..Q:+$G(^%ZIS(1,SDID,90)) ;out of service
..S SDCNT=SDCNT+1 S @RET@(SDCNT)=SDID_U_DN_U_$$GET1^DIQ(3.5,SDID_",",.02,"E")_$C(30)
Q
P ;Printers only on current namespace
N DN,SDID
K ^UTILITY("ZIS",$J) ;^UTILITY is already used in device processing
D LCPU
S DN=$S($P(LSUB,"|",1)'="":$P(LSUB,"|",1),PARTIAL'="":$$GETSUB^SDECU(PARTIAL),1:"")
F S DN=$O(^UTILITY("ZIS",$J,"DEVLST","B",DN)) Q:DN="" Q:(PARTIAL'="")&(DN'[PARTIAL) D I SDCNT>MAX S SDSUB=DN_"|"_SDID Q
.S SDID=$S($P(LSUB,"|",2)'="":$P(LSUB,"|",2),1:0)
.S LSUB=""
.F S SDID=$O(^UTILITY("ZIS",$J,"DEVLST","B",DN,SDID)) Q:SDID="" D I SDCNT>MAX S SDSUB=DN_"|"_SDID Q
..Q:'$D(^%ZIS(1,SDID,0)) ;existence check
..Q:$P($G(^%ZIS(2,+$G(^%ZIS(1,SDID,"SUBTYPE")),0)),U)'?1"P".E ;subtype check
..Q:+$G(^%ZIS(1,SDID,90)) ;out of service
..S SDCNT=SDCNT+1 S @RET@(SDCNT)=SDID_U_DN_U_$$GET1^DIQ(3.5,SDID_",",.02,"E")_$C(30)
K ^UTILITY("ZIS",$J)
Q
LCPU ;build list of local devices (namespace text needs to be in VOLUME SET(CPU) field)
N %ZISV
;S %ZISV=$G(^%ZOSF("VOL"))
S %ZISV="TIS"
Q:%ZISV=""
D LCPU^%ZIS5
Q
;
;===
;
PRINT(RET,APID,TYPE,SDID) ;Print patient letters
;INPUT:
; APID - (required) Appointment ID pointer to SDEC APPOINTMENT file (#409.84)
; TYPE - (required) Letter type
; P:Pre-Appointment
; C:Cancel Appointment
; N:No Show
; SDID - (required) Printer Device ID pointer to DEVICE file (#3.5)
;RETURN:
; CODE ^ MESSAGE
; CODE - 0=Success; -1=error
; MESSAGE
N A,DFN,J,L,L0,L2,S,S1,SC,ZTS
N SD9,SDAMTYP,SDBD,SDCL,SDC,SDCLN,SDED,SDFN,SDFIRST,SDFORM,SDLET,SDLET1,SDLT,SDNOD,SDRES,SDT,SDTTM,SDV1,SDWH,SDX,SDY
N VAUTNALL,VAUTNI
S SDFIRST=1
S RET=$NA(^TMP("SDECDEV",$J,"PRINT"))
K @RET
S @RET@(0)="I00030CODE^T00500MESSAGE"_$C(30)
;validate APID
S APID=$G(APID)
I APID="" S @RET@(1)="-1^Appointment ID is required."_$C(30,31) Q
I '$D(^SDEC(409.84,APID,0)) S @RET@(1)="-1^Invalid Appointment ID."_$C(30,31) Q
;validate TYPE
S TYPE=$G(TYPE)
I TYPE="" S @RET@(1)="-1^Letter Type is required."_$C(30,31) Q
I "PCN"'[TYPE S @RET@(1)="-1^Invalid Letter Type."_$C(30,31) Q
;validate SDID
S SDID=$G(SDID)
I SDID="" S @RET@(1)="-1^Device ID is required."_$C(30,31) Q
I '$D(^%ZIS(1,SDID,0)) S @RET@(1)="-1^Invalid Device ID."_$C(30,31) Q
;
S SDNOD=$G(^SDEC(409.84,APID,0))
I SDNOD="" S @RET@(1)="-1^Error getting Appointment data."_$C(30,31) Q
S DFN=$P(SDNOD,U,5)
;check bad address
I $$BADADR^DGUTL3(+DFN) S @RET@(1)="-1^THIS PATIENT HAS BEEN FLAGGED WITH A BAD ADDRESS INDICATOR, NO LETTER WILL BE PRINTED."_$C(30,31) Q
;
S SDRES=$P(SDNOD,U,7)
I SDRES="" S @RET@(1)="-1^Resource is not defined for this appointment."_$C(30,31) Q
S SC=$$GET1^DIQ(409.831,SDRES_",",.04,"I")
I SC="" S @RET@(1)="-1^Clinic is not defined for the resource."_$C(30,31) Q
S (SDT,SDTTM)=$P(SDNOD,U,1)
S SDWH=$P(SDNOD,U,17)
S @RET@(1)="0^SUCCESS"_$C(30)
D PRE:TYPE="P",CAN:TYPE="C",NS:TYPE="N"
S @RET@(1)=@RET@(1)_$C(31)
Q
;
;
PRE ;print pre-appointment letter
S SDY=0 F S SDY=$O(^SC(SC,"S",SDTTM,1,SDY)) Q:SDY="" Q:$P($G(^SC(SC,"S",SDTTM,1,SDY,0)),U,1)=DFN
I SDY="" S @RET@(1)="-1^Clinic appointment not found."_$C(30) Q
;check for a PRE-APPT letter defined
I $P($G(^SC(SC,"LTR")),U,2)="" S @RET@(1)="-1^A pre-appointment letter is not defined for "_$$GET1^DIQ(44,SC_",",.01)_"."_$C(30) Q
;
; pre-define letter type (P), the division, date for appt, etc.
S (SDBD,SDED)=SDTTM,L0="P",SD9=0,VAUTNALL=1,VAUTNI=2,S1="P",SDLT=1,SDV1=1,SDFORM=""
S L2=$S(L0="P":"^SDL1",1:"^SDL1"),J=SDBD
S (A,SDFN,S)=DFN,L="^SDL1",SDCL=+$P(^SC(SC,0),U,1),SDC=SC,SDX=SDTTM
S SDLET=$P(^SC(SC,"LTR"),U,2) ; letter IEN
S SDLET1=SDLET
S SDAMTYP="P" ;always by patient
;I SDY["DPT(" S SDAMTYP="P",SDFN=+SDY
;I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY
; prepare to queue the letter if the user so desires
N %ZIS,IOP,POP,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S IOP="`"_SDID
S %ZIS("B")="",POP=0,%ZIS="MQ" D ^%ZIS
I POP S @RET@(1)="-1^Print error."_$C(30) Q
S ZTIO=ION,ZTRTN="QUE^SDM1A",ZTDESC="PRINT PRE-APPT LETTER",ZTDTH=$$NOW^XLFDT ;,ZTSAVE("*")=""
F ZTS="A","AUTO(","DFN","DUZ","S","SC","SDCL","SDFORM","SDLET","SDWH","SDX" S ZTSAVE(ZTS)=""
D ^%ZTLOAD K IO("Q")
Q
;
CAN ;print cancel-appointment letter
N A,SDCL,SDL
S SDL=""
S A=DFN
S SDCL(1)=SC_U_SDTTM
I $D(^SC(SC,"LTR")) S:SDWH["P" SDL=$P(^SC(SC,"LTR"),"^",4) S:SDWH'["P" SDL=$P(^SC(SC,"LTR"),"^",3)
I SDL="" S @RET@(1)="-1^Clinic is not assigned a "_$S(SDWH["P":"clinic",1:"appointment")_" cancellation letter"_$C(30) Q
;
N %ZIS,POP,ZTDESC,ZTIO,ZTRTN,ZTSAVE
S SDWH=$G(SDWH)
I SDWH'="C",SDWH'="PC" S @RET@(1)="-1^Invalid Cancel Status"_$C(30) Q
S IOP="`"_SDID
S %ZIS("B")="",POP=0,%ZIS="MQ" D ^%ZIS ;alb/sat 665 - change ^%ZIS params to match PRE
I POP S @RET@(1)="-1^Print error."_$C(30) Q
S ZTIO=ION,ZTRTN="SDLET^SDCNP1A",ZTDESC="PRINT CANCEL APPOINTMENT LETTER",ZTDTH=$$NOW^XLFDT F ZTS="SDCL(","DUZ","DFN","DT","A","SDWH","AUTO(" S ZTSAVE(ZTS)=""
K ZTS D ^%ZTLOAD K IO("Q")
Q
;
NS ;print no-show appointment letter
N ALS,ANS,C,DATEND,SDDT,SDLET,SDLT1,SDMSG,SDNSACT,SDTIME,SDV1
I SDT="" S @RET@(1)="-1^Print error."_$C(30) Q
S SDT=$P(SDT,".",1)
S ALS="Y",ANS="N",C=SC,SDDT=DT
S DATEND=SDT+.9
S (SDLT1,SDLET)=""
S SDNSACT=0
S SDV1=$O(^DG(40.8,0))
S SDTIME=$P(SDNOD,U,23)
S:SDTIME="" SDTIME="*"
S SDMSG=" DOES NOT HAVE A NO-SHOW LETTER ASSIGNED TO IT!"
I '$D(^SC(C,"LTR")) S @RET@(1)="-1^"_$P(^SC(C,0),"^")_SDMSG Q
I $D(^SC(C,"LTR")),'+^SC(C,"LTR") S @RET@(1)="-1^"_$P(^SC(C,0),"^")_SDMSG Q
I $D(^SC(C,"LTR")),+^SC(C,"LTR") S SDLET=+^("LTR")
I SDLET="" S @RET@(1)="-1^"_$P(^SC(C,0),"^")_SDMSG Q
S IOP="`"_SDID
S %ZIS("B")="",POP=0,%ZIS="MQ" D ^%ZIS ;alb/sat 665 - change ^%ZIS params to match PRE
I POP S @RET@(1)="-1^Print error."_$C(30) Q
S ZTIO=ION,ZTRTN="START^SDN0",ZTDESC="PRINT NO SHOW APPOINTMENT LETTER",ZTDTH=$$NOW^XLFDT F ZTS="SC","SDDT","ALS","ANS","SDLET","SDV1","SDT","C","DATEND","SDTIME","SDLT1","AUTO(","SDNSACT" S ZTSAVE(ZTS)=""
K ZTS D ^%ZTLOAD K IO("Q")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECDEV 9948 printed Nov 22, 2024@18:01:56 Page 2
SDECDEV ;ALB/SAT - VISTA SCHEDULING RPCS ;JUN 21, 2017
+1 ;;5.3;Scheduling;**627,658,665**;Aug 13, 1993;Build 14
+2 ;
+3 QUIT
+4 ;
DEVICE(SDECY) ;EP List of printers
+1 ; OUTPUT:
+2 ; SDECY(n)=REPORT TEXT
+3 ;
+4 NEW SDECI,FROM,DIR,ARR
+5 SET SDECI=0
+6 SET SDECY=$NAME(^TMP("SDECDEV",$JOB,"DEVICE"))
KILL @SDECY
+7 SET @SDECY@(SDECI)="I00030PRINTER_IEN^T00040PRINTER_NAME"_$CHAR(30)
+8 NEW CNT,IEN,X,Y,X0,XLOC,XSEC,XTYPE,XSTYPE,XTIME,XOSD,MW,PL,DEV
+9 SET FROM=""
SET DIR=1
+10 FOR
SET FROM=$ORDER(^%ZIS(1,"B",FROM),DIR)
SET IEN=0
if FROM=""
QUIT
Begin DoDot:1
+11 FOR
SET IEN=$ORDER(^%ZIS(1,"B",FROM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+12 if $DATA(ARR(IEN))
QUIT
+13 SET ARR(IEN)=""
+14 SET DEV=""
SET X0=$GET(^%ZIS(1,IEN,0))
SET XLOC=$PIECE($GET(^(1)),U)
SET XOSD=+$GET(^(90))
SET MW=$GET(^(91))
SET XSEC=$GET(^(95))
SET XSTYPE=+$GET(^("SUBTYPE"))
SET XTIME=$PIECE($GET(^("TIME")),U)
SET XTYPE=$PIECE($GET(^("TYPE")),U)
+15 ; Printers only
if $EXTRACT($GET(^%ZIS(2,XSTYPE,0)))'="P"
QUIT
+16 if "^TRM^HG^CHAN^OTH^"'[(U_XTYPE_U)
QUIT
+17 ; Queuing allowed
if $PIECE(X0,U,2)="0"!($PIECE(X0,U,12)=2)
QUIT
+18 ; Out of Service
IF XOSD
IF XOSD'>DT
QUIT
+19 ; Prohibited Times
IF $LENGTH(XTIME)
Begin DoDot:3
+20 SET Y=$PIECE($HOROLOG,",",2)
SET Y=Y\60#60+(Y\3600*100)
SET X=$PIECE(XTIME,"-",2)
+21 if X'<XTIME&(Y'>X&(Y'<XTIME))!(X<XTIME&(Y'<XTIME!(Y'>X)))
SET XTIME=""
End DoDot:3
if '$LENGTH(XTIME)
QUIT
+22 IF $LENGTH(XSEC)
IF $GET(DUZ(0))'="@"
IF $TRANSLATE(XSEC,$GET(DUZ(0)))=XSEC
QUIT
+23 SET PL=$PIECE(MW,U,3)
SET MW=$PIECE(MW,U)
SET X=$GET(^%ZIS(2,XSTYPE,1))
+24 if 'MW
SET MW=$PIECE(X,U)
+25 if 'PL
SET PL=$PIECE(X,U,3)
+26 SET X=$PIECE(X0,U)
+27 if $EXTRACT(X,1,4)["NULL"
QUIT
+28 if X'=FROM
SET X=FROM_" <"_X_">"
+29 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=IEN_U_$PIECE(X0,U)_$CHAR(30)
End DoDot:2
End DoDot:1
+30 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+31 QUIT
+32 ;
DEV(RET,TYPE,MAX,LSUB,PARTIAL) ;GET devices of the given type ;alb/sat 658
+1 ;INPUT:
+2 ; TYPE - (optional) Device type
+3 ; A:All Printers (default)
+4 ; P:Printers only on current namespace
+5 ; C:Complete Device Listing (not supported)
+6 ; D:Devices only on current namespace (not supported)
+7 ; N:New Format for Device Specification (not supported)
+8 ; E:Extended Help (not supported)
+9 ; MAX - (optional) Max records to return
+10 ; LSUB - (optional) Last subscripts used to continue from last call
+11 ; Use LASTSUB (return piece 3) from previous call
+12 ; PARTIAL - (optional) - partial device name lookup
+13 ;RETURN:
+14 ; DIEN = Device IEN pointer to DEVICE file (#3.5) OR -1 if error
+15 ; DNAME = Device Name OR message if error
+16 ; LOCT = Location of Terminal text
+17 ; LASTSUB = Last subscripts to continue with next call
+18 ; Pass in as LSUB input
+19 NEW SDCNT,SDSUB,SDTMP
+20 SET SDSUB=""
+21 SET SDCNT=0
+22 SET RET=$NAME(^TMP("SDECDEV",$JOB,"DEV"))
+23 KILL @RET
+24 SET SDTMP="T00030DIEN^T00030DNAME^T00050LOCT^T00100LASTSUB"
+25 SET @RET@(0)=SDTMP_$CHAR(30)
+26 ;validate TYPE
+27 SET TYPE=$GET(TYPE)
+28 IF TYPE=""
SET TYPE="A"
+29 ;"APCDNE"
IF "AP"'[TYPE
SET @RET@(1)="-1^Invalid Device Type - "_TYPE_"."_$CHAR(30,31)
QUIT
+30 ;validate MAX
+31 SET MAX=$GET(MAX)
+32 IF MAX'=""
IF MAX'=+MAX
SET @RET@(1)="-1^Invalid max records value - "_MAX_"."_$CHAR(30,31)
QUIT
+33 if MAX=""
SET MAX=9999999
+34 ;validate LSUB
+35 SET LSUB=$GET(LSUB)
+36 ;validate PARTIAL
+37 SET PARTIAL=$GET(PARTIAL)
+38 ;
+39 DO @TYPE
+40 ;
+41 IF SDSUB'=""
SET SDTMP=$PIECE(@RET@(SDCNT),$CHAR(30),1)
SET $PIECE(SDTMP,U,4)=SDSUB
SET @RET@(SDCNT)=SDTMP_$CHAR(30)
+42 SET @RET@(SDCNT)=@RET@(SDCNT)_$CHAR(31)
+43 QUIT
A ;All Printers
+1 NEW DN,SDID
+2 SET DN=$SELECT($PIECE(LSUB,"|",1)'="":$PIECE(LSUB,"|",1),PARTIAL'="":$$GETSUB^SDECU(PARTIAL),1:"")
+3 FOR
SET DN=$ORDER(^%ZIS(1,"B",DN))
if DN=""
QUIT
if (PARTIAL'="")&(DN'[PARTIAL)
QUIT
Begin DoDot:1
+4 SET SDID=$SELECT($PIECE(LSUB,"|",2)'="":$PIECE(LSUB,"|",2),1:0)
+5 SET LSUB=""
+6 FOR
SET SDID=$ORDER(^%ZIS(1,"B",DN,SDID))
if SDID=""
QUIT
Begin DoDot:2
+7 ;existence check
if '$DATA(^%ZIS(1,SDID,0))
QUIT
+8 ;subtype check
if $PIECE($GET(^%ZIS(2,+$GET(^%ZIS(1,SDID,"SUBTYPE")),0)),U)'?1"P".E
QUIT
+9 ;out of service
if +$GET(^%ZIS(1,SDID,90))
QUIT
+10 SET SDCNT=SDCNT+1
SET @RET@(SDCNT)=SDID_U_DN_U_$$GET1^DIQ(3.5,SDID_",",.02,"E")_$CHAR(30)
End DoDot:2
IF SDCNT>MAX
SET SDSUB=DN_"|"_SDID
QUIT
End DoDot:1
IF SDCNT>MAX
SET SDSUB=DN_"|"_SDID
QUIT
+11 QUIT
P ;Printers only on current namespace
+1 NEW DN,SDID
+2 ;^UTILITY is already used in device processing
KILL ^UTILITY("ZIS",$JOB)
+3 DO LCPU
+4 SET DN=$SELECT($PIECE(LSUB,"|",1)'="":$PIECE(LSUB,"|",1),PARTIAL'="":$$GETSUB^SDECU(PARTIAL),1:"")
+5 FOR
SET DN=$ORDER(^UTILITY("ZIS",$JOB,"DEVLST","B",DN))
if DN=""
QUIT
if (PARTIAL'="")&(DN'[PARTIAL)
QUIT
Begin DoDot:1
+6 SET SDID=$SELECT($PIECE(LSUB,"|",2)'="":$PIECE(LSUB,"|",2),1:0)
+7 SET LSUB=""
+8 FOR
SET SDID=$ORDER(^UTILITY("ZIS",$JOB,"DEVLST","B",DN,SDID))
if SDID=""
QUIT
Begin DoDot:2
+9 ;existence check
if '$DATA(^%ZIS(1,SDID,0))
QUIT
+10 ;subtype check
if $PIECE($GET(^%ZIS(2,+$GET(^%ZIS(1,SDID,"SUBTYPE")),0)),U)'?1"P".E
QUIT
+11 ;out of service
if +$GET(^%ZIS(1,SDID,90))
QUIT
+12 SET SDCNT=SDCNT+1
SET @RET@(SDCNT)=SDID_U_DN_U_$$GET1^DIQ(3.5,SDID_",",.02,"E")_$CHAR(30)
End DoDot:2
IF SDCNT>MAX
SET SDSUB=DN_"|"_SDID
QUIT
End DoDot:1
IF SDCNT>MAX
SET SDSUB=DN_"|"_SDID
QUIT
+13 KILL ^UTILITY("ZIS",$JOB)
+14 QUIT
LCPU ;build list of local devices (namespace text needs to be in VOLUME SET(CPU) field)
+1 NEW %ZISV
+2 ;S %ZISV=$G(^%ZOSF("VOL"))
+3 SET %ZISV="TIS"
+4 if %ZISV=""
QUIT
+5 DO LCPU^%ZIS5
+6 QUIT
+7 ;
+8 ;===
+9 ;
PRINT(RET,APID,TYPE,SDID) ;Print patient letters
+1 ;INPUT:
+2 ; APID - (required) Appointment ID pointer to SDEC APPOINTMENT file (#409.84)
+3 ; TYPE - (required) Letter type
+4 ; P:Pre-Appointment
+5 ; C:Cancel Appointment
+6 ; N:No Show
+7 ; SDID - (required) Printer Device ID pointer to DEVICE file (#3.5)
+8 ;RETURN:
+9 ; CODE ^ MESSAGE
+10 ; CODE - 0=Success; -1=error
+11 ; MESSAGE
+12 NEW A,DFN,J,L,L0,L2,S,S1,SC,ZTS
+13 NEW SD9,SDAMTYP,SDBD,SDCL,SDC,SDCLN,SDED,SDFN,SDFIRST,SDFORM,SDLET,SDLET1,SDLT,SDNOD,SDRES,SDT,SDTTM,SDV1,SDWH,SDX,SDY
+14 NEW VAUTNALL,VAUTNI
+15 SET SDFIRST=1
+16 SET RET=$NAME(^TMP("SDECDEV",$JOB,"PRINT"))
+17 KILL @RET
+18 SET @RET@(0)="I00030CODE^T00500MESSAGE"_$CHAR(30)
+19 ;validate APID
+20 SET APID=$GET(APID)
+21 IF APID=""
SET @RET@(1)="-1^Appointment ID is required."_$CHAR(30,31)
QUIT
+22 IF '$DATA(^SDEC(409.84,APID,0))
SET @RET@(1)="-1^Invalid Appointment ID."_$CHAR(30,31)
QUIT
+23 ;validate TYPE
+24 SET TYPE=$GET(TYPE)
+25 IF TYPE=""
SET @RET@(1)="-1^Letter Type is required."_$CHAR(30,31)
QUIT
+26 IF "PCN"'[TYPE
SET @RET@(1)="-1^Invalid Letter Type."_$CHAR(30,31)
QUIT
+27 ;validate SDID
+28 SET SDID=$GET(SDID)
+29 IF SDID=""
SET @RET@(1)="-1^Device ID is required."_$CHAR(30,31)
QUIT
+30 IF '$DATA(^%ZIS(1,SDID,0))
SET @RET@(1)="-1^Invalid Device ID."_$CHAR(30,31)
QUIT
+31 ;
+32 SET SDNOD=$GET(^SDEC(409.84,APID,0))
+33 IF SDNOD=""
SET @RET@(1)="-1^Error getting Appointment data."_$CHAR(30,31)
QUIT
+34 SET DFN=$PIECE(SDNOD,U,5)
+35 ;check bad address
+36 IF $$BADADR^DGUTL3(+DFN)
SET @RET@(1)="-1^THIS PATIENT HAS BEEN FLAGGED WITH A BAD ADDRESS INDICATOR, NO LETTER WILL BE PRINTED."_$CHAR(30,31)
QUIT
+37 ;
+38 SET SDRES=$PIECE(SDNOD,U,7)
+39 IF SDRES=""
SET @RET@(1)="-1^Resource is not defined for this appointment."_$CHAR(30,31)
QUIT
+40 SET SC=$$GET1^DIQ(409.831,SDRES_",",.04,"I")
+41 IF SC=""
SET @RET@(1)="-1^Clinic is not defined for the resource."_$CHAR(30,31)
QUIT
+42 SET (SDT,SDTTM)=$PIECE(SDNOD,U,1)
+43 SET SDWH=$PIECE(SDNOD,U,17)
+44 SET @RET@(1)="0^SUCCESS"_$CHAR(30)
+45 if TYPE="P"
DO PRE
if TYPE="C"
DO CAN
if TYPE="N"
DO NS
+46 SET @RET@(1)=@RET@(1)_$CHAR(31)
+47 QUIT
+48 ;
+49 ;
PRE ;print pre-appointment letter
+1 SET SDY=0
FOR
SET SDY=$ORDER(^SC(SC,"S",SDTTM,1,SDY))
if SDY=""
QUIT
if $PIECE($GET(^SC(SC,"S",SDTTM,1,SDY,0)),U,1)=DFN
QUIT
+2 IF SDY=""
SET @RET@(1)="-1^Clinic appointment not found."_$CHAR(30)
QUIT
+3 ;check for a PRE-APPT letter defined
+4 IF $PIECE($GET(^SC(SC,"LTR")),U,2)=""
SET @RET@(1)="-1^A pre-appointment letter is not defined for "_$$GET1^DIQ(44,SC_",",.01)_"."_$CHAR(30)
QUIT
+5 ;
+6 ; pre-define letter type (P), the division, date for appt, etc.
+7 SET (SDBD,SDED)=SDTTM
SET L0="P"
SET SD9=0
SET VAUTNALL=1
SET VAUTNI=2
SET S1="P"
SET SDLT=1
SET SDV1=1
SET SDFORM=""
+8 SET L2=$SELECT(L0="P":"^SDL1",1:"^SDL1")
SET J=SDBD
+9 SET (A,SDFN,S)=DFN
SET L="^SDL1"
SET SDCL=+$PIECE(^SC(SC,0),U,1)
SET SDC=SC
SET SDX=SDTTM
+10 ; letter IEN
SET SDLET=$PIECE(^SC(SC,"LTR"),U,2)
+11 SET SDLET1=SDLET
+12 ;always by patient
SET SDAMTYP="P"
+13 ;I SDY["DPT(" S SDAMTYP="P",SDFN=+SDY
+14 ;I SDY["SC(" S SDAMTYP="C",SDCLN=+SDY
+15 ; prepare to queue the letter if the user so desires
+16 NEW %ZIS,IOP,POP,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+17 SET IOP="`"_SDID
+18 SET %ZIS("B")=""
SET POP=0
SET %ZIS="MQ"
DO ^%ZIS
+19 IF POP
SET @RET@(1)="-1^Print error."_$CHAR(30)
QUIT
+20 ;,ZTSAVE("*")=""
SET ZTIO=ION
SET ZTRTN="QUE^SDM1A"
SET ZTDESC="PRINT PRE-APPT LETTER"
SET ZTDTH=$$NOW^XLFDT
+21 FOR ZTS="A","AUTO(","DFN","DUZ","S","SC","SDCL","SDFORM","SDLET","SDWH","SDX"
SET ZTSAVE(ZTS)=""
+22 DO ^%ZTLOAD
KILL IO("Q")
+23 QUIT
+24 ;
CAN ;print cancel-appointment letter
+1 NEW A,SDCL,SDL
+2 SET SDL=""
+3 SET A=DFN
+4 SET SDCL(1)=SC_U_SDTTM
+5 IF $DATA(^SC(SC,"LTR"))
if SDWH["P"
SET SDL=$PIECE(^SC(SC,"LTR"),"^",4)
if SDWH'["P"
SET SDL=$PIECE(^SC(SC,"LTR"),"^",3)
+6 IF SDL=""
SET @RET@(1)="-1^Clinic is not assigned a "_$SELECT(SDWH["P":"clinic",1:"appointment")_" cancellation letter"_$CHAR(30)
QUIT
+7 ;
+8 NEW %ZIS,POP,ZTDESC,ZTIO,ZTRTN,ZTSAVE
+9 SET SDWH=$GET(SDWH)
+10 IF SDWH'="C"
IF SDWH'="PC"
SET @RET@(1)="-1^Invalid Cancel Status"_$CHAR(30)
QUIT
+11 SET IOP="`"_SDID
+12 ;alb/sat 665 - change ^%ZIS params to match PRE
SET %ZIS("B")=""
SET POP=0
SET %ZIS="MQ"
DO ^%ZIS
+13 IF POP
SET @RET@(1)="-1^Print error."_$CHAR(30)
QUIT
+14 SET ZTIO=ION
SET ZTRTN="SDLET^SDCNP1A"
SET ZTDESC="PRINT CANCEL APPOINTMENT LETTER"
SET ZTDTH=$$NOW^XLFDT
FOR ZTS="SDCL(","DUZ","DFN","DT","A","SDWH","AUTO("
SET ZTSAVE(ZTS)=""
+15 KILL ZTS
DO ^%ZTLOAD
KILL IO("Q")
+16 QUIT
+17 ;
NS ;print no-show appointment letter
+1 NEW ALS,ANS,C,DATEND,SDDT,SDLET,SDLT1,SDMSG,SDNSACT,SDTIME,SDV1
+2 IF SDT=""
SET @RET@(1)="-1^Print error."_$CHAR(30)
QUIT
+3 SET SDT=$PIECE(SDT,".",1)
+4 SET ALS="Y"
SET ANS="N"
SET C=SC
SET SDDT=DT
+5 SET DATEND=SDT+.9
+6 SET (SDLT1,SDLET)=""
+7 SET SDNSACT=0
+8 SET SDV1=$ORDER(^DG(40.8,0))
+9 SET SDTIME=$PIECE(SDNOD,U,23)
+10 if SDTIME=""
SET SDTIME="*"
+11 SET SDMSG=" DOES NOT HAVE A NO-SHOW LETTER ASSIGNED TO IT!"
+12 IF '$DATA(^SC(C,"LTR"))
SET @RET@(1)="-1^"_$PIECE(^SC(C,0),"^")_SDMSG
QUIT
+13 IF $DATA(^SC(C,"LTR"))
IF '+^SC(C,"LTR")
SET @RET@(1)="-1^"_$PIECE(^SC(C,0),"^")_SDMSG
QUIT
+14 IF $DATA(^SC(C,"LTR"))
IF +^SC(C,"LTR")
SET SDLET=+^("LTR")
+15 IF SDLET=""
SET @RET@(1)="-1^"_$PIECE(^SC(C,0),"^")_SDMSG
QUIT
+16 SET IOP="`"_SDID
+17 ;alb/sat 665 - change ^%ZIS params to match PRE
SET %ZIS("B")=""
SET POP=0
SET %ZIS="MQ"
DO ^%ZIS
+18 IF POP
SET @RET@(1)="-1^Print error."_$CHAR(30)
QUIT
+19 SET ZTIO=ION
SET ZTRTN="START^SDN0"
SET ZTDESC="PRINT NO SHOW APPOINTMENT LETTER"
SET ZTDTH=$$NOW^XLFDT
FOR ZTS="SC","SDDT","ALS","ANS","SDLET","SDV1","SDT","C","DATEND","SDTIME","SDLT1","AUTO(","SDNSACT"
SET ZTSAVE(ZTS)=""
+20 KILL ZTS
DO ^%ZTLOAD
KILL IO("Q")
+21 QUIT
