- 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 Feb 19, 2025@00:18:21 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