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

SDECDEV.m

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