PSJPDAPP ;BIR/MHA - SEND APPOINTMENTS TO PADE ;11/27/15
;;5.0;INPATIENT MEDICATIONS;**317,389,415,432**;16 DEC 97;Build 18
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^ORD(101 supported by DBIA 872
;Reference to GETPLIST^SDAMA202 supported by DBIA 3869
;Reference to ^SC supported by DBIA 10040
;Reference to ^DPT supported by DBIA 10035
Q
;
EN ;
N PDA,PDCL,PDCLA,PDI,PDJ,PDK,PSJAP,PSJCLPD,PSJPDNM,PSJDIV,DTP,SA,SEQ,I,J,K,L,P,X,Y,Z,PSJNIP,X1,X2
S (DTP,PSJAP,I)=0
K ^TMP($J,"PSJCLSA")
F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
Q:'PSJAP
S I=0 F S I=$O(PSJAP(I)) Q:'I D
. S DTP=+$G(^PS(58.7,I,1))
. S J=0 F S J=$O(^PS(58.7,I,"DIV",J)) Q:'J D
.. S Y=$G(^PS(58.7,I,"DIV",J,0)) I Y=""!($P(Y,"^",2)&($P(Y,"^",2)<DT)) Q
.. S SA=""
.. I $P(Y,"^",9)="Y" S:$P(Y,"^",4) SA=$P($G(^PS(58.71,$P(Y,"^",4),0)),"^") D ALLCLN ;send appt for all clinics
.. D CLARR
.. ; Get all CLINIC to SEND AREA associations, where
.. ; INCLUDE CLINICS IN BG JOB and RE-SEND ORDERS AT CHECK-IN evaluates to YES
.. D GETDSARS^PSJPDAPP(I,J,3)
M PDCL=PDCLA
I '$D(PDCL) D KILLTMP Q
N SNM,CNM S SNM="PSJ SIU-S12 SERVER",CNM="PSJ SIU-S12 CLIENT"
I '$O(^ORD(101,"B",SNM,0))!('$O(^ORD(101,"B",CNM,0))) Q
N NHL D INIT^HLFNC2(SNM,.NHL) Q:$D(NHL)=1
N NFS,NECH,HL,HLFS,NSEG,EDT,APT,DFN,PSJDTM,PSJND,PSJVP,PSJVNM,PSJDNS,PSJDNM,PSJOR,PSJORN
M HL=NHL S (NFS,HLFS)=HL("FS"),NECH=$E(HL("ECH"),1)
S PDI=0 F S PDI=$O(PDCL(PDI)) Q:'PDI D
. S PSJND=$G(^PS(58.7,PDI,0))
. S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
. S PDJ=0 F S PDJ=$O(PDCL(PDI,PDJ)) Q:'PDJ D
.. S PSJDNM=$P($$SITE^VASITE(,PDJ),"^",3)
.. S PDK=0 F S PDK=$O(PDCL(PDI,PDJ,PDK)) Q:'PDK D APPT
D KILLTMP
Q
;
APPT ;
K ^TMP($J,"SDAMA202")
S PSJOR=PDK,PSJORN=$P(^SC(PDK,0),"^")
S DTP=PDCL(PDI,PDJ,PDK)
S EDT=DT
I DTP S X1=DT,X2=+DTP D C^%DTC S EDT=X
D GETPLIST^SDAMA202(PDK,"1;4","",DT,EDT)
Q:'$D(^TMP($J,"SDAMA202"))
K APDTM,CLNM,PSJXCL
S PDA=0 F S PDA=$O(^TMP($J,"SDAMA202","GETPLIST",PDA)) Q:'PDA D
. S PSJDTM=+^TMP($J,"SDAMA202","GETPLIST",PDA,1)
. S DFN=+^TMP($J,"SDAMA202","GETPLIST",PDA,4)
. Q:$P($G(^DPT(DFN,.1)),"^")]""&($P(^PS(58.7,PDI,0),"^",6)'="Y")
. K NSEG N ZZ1,XX,FTS S (ZZ1,FTS)="",PSJNIP=0
. I $P($G(^DPT(DFN,.1)),"^")]"" D
.. D IN5^VADPT
.. N PSJQ,PSJWD,PSJRBD
.. S PSJWD=$P(VAIP(5),"^",2),PSJRBD=$P(VAIP(6),"^",2)
.. S PSJQ=$$CHKPD^PSJPDCL(PSJWD,PSJRBD)
.. I 'PSJQ S PSJNIP=1 Q
.. S FTS=$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2)
.. S XX=0 F S XX=$O(PSJQ(XX)) Q:'XX D
... I XX=PDI,$P(PSJQ(XX),"^",2)'="" S ZZ1=$P(PSJQ(XX),"^",2)
... I XX'=PDI S PSJNIP=1
... I $G(PSJXCL(PDI)) S PSJNIP=0
. S SEQ=0 D SRBLD^PSJPDCLA M HL=NHL N ZZ2 S ZZ2=$S($P(DTP,"^",2)'="":$P(DTP,"^",2),1:"")
. S SEQ=SEQ+1,NSEG(SEQ)="ZZZ"_HL("FS")_$S(ZZ1'="":ZZ1,1:"")_HL("FS")_ZZ2_HL("FS")_FTS
. K HLP,HLA,PSJSND S HLP="",HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
. N XX S XX=PDI D PV19 M HLA("HLS")=NSEG
. D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
. D LOG^PSJPADE
. ;check for O11 re-send
. D RESNDORDS^PSJPDCLA(DFN,PSJOR,PDJ,PDI,3) ; Resend all orders for the input CLINIC's SEND AREA
Q
;
ALLCLN ;
N ND S Z=0 F S Z=$O(^SC(Z)) Q:'Z D
.S ND=^SC(Z,0) Q:$P(ND,"^",3)'="C" Q:$P(ND,"^",15)'=J
.I $D(^SC(Z,"I")) S X=$G(^SC(Z,"I")) I $P(X,"^"),$P(X,"^",2)'>$P(X,"^") Q
.S PDCL(I,J,Z)=DTP_$S(SA]"":"^"_SA,1:"")
Q
;
CLARR ;
S Z=0,SA=""
F S Z=$O(^PS(58.7,I,"DIV",J,"CL",Z)) Q:'Z S K=^PS(58.7,I,"DIV",J,"CL",Z,0) D:$P(K,"^",3)="Y"
. S SA=$P(K,"^",2)
. S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S PDCLA(I,J,+K)=DTP_$S(SA]"":"^"_SA,1:"")
S Z=0
F S Z=$O(^PS(58.7,I,"DIV",J,"PCG",Z)) Q:'Z D:$P($G(^PS(58.7,I,"DIV",J,"PCG",Z,2)),"^")="Y"
. S SA=$P($G(^PS(58.7,I,"DIV",J,"PCG",Z,0)),"^",2)
. S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S X=0 F S X=$O(^PS(58.7,I,"DIV",J,"PCG",Z,1,X)) Q:'X D
.. S K=+$G(^PS(58.7,I,"DIV",J,"PCG",Z,1,X,0))
.. I '$D(PDCLA(I,J,K)) S PDCLA(I,J,K)=DTP_$S(SA]"":"^"_SA,1:"")
S Z=0
F S Z=$O(^PS(58.7,I,"DIV",J,"VCG",Z)) Q:'Z S X=^PS(58.7,I,"DIV",J,"VCG",Z,0) D:$P(X,"^",3)="Y"
. S SA=$P(X,"^",2) S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S Y=0 F S Y=$O(^PS(57.8,+X,1,Y)) Q:'Y D
.. S K=+^(Y,0) S:'$D(PDCLA(I,J,K)) PDCLA(I,J,K)=DTP_$S(SA]"":"^"_SA,1:"")
S Z=0,L=""
F S Z=$O(^PS(58.7,I,"DIV",J,"WCN",Z)) Q:'Z S X=^PS(58.7,I,"DIV",J,"WCN",Z,0) D:$P(X,"^",3)="Y"
. S SA=$P(X,"^",2) S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S Y=$P(X,"^"),P=$E(X,1,$L(Y)-1) F S P=$O(^SC("B",P)) Q:P="" D
.. Q:($E(P,1,$L(Y))'=Y) ;p415
.. S K=$O(^SC("B",P,0)),L=$G(^SC(K,0)) Q:$P(L,"^",3)'="C" Q:$P(L,"^",15)'=J
.. S:'$D(PDCLA(I,J,K)) PDCLA(I,J,K)=DTP_$S(SA]"":"^"_SA,1:"")
Q
;
PV19 ;
N NC,NDFN,NCLI,N19,NSA,NS,NWDI,NQ
S (NSA,N19)="",(NQ,NC)=0,NS=$E(HL("ECH"),1),PDL(10)=XX,PDL(4)=HL("ETN")
S:ZZ2]"" (NSA,PDL(12))=$O(^PS(58.71,"B",ZZ2,0))
S:ZZ1]"" PDL(11)=$O(^PS(58.71,"B",ZZ1,""))
F S NC=$O(NSEG(NC)) Q:'NC D Q:NQ
. I $E(NSEG(NC),1,3)="PID" S (NDFN,PDL(1))=+$P(NSEG(NC),HL("FS"),4) Q
. I $E(NSEG(NC),1,3)="PV1" D S NQ=1 Q
.. I $P(NSEG(NC),HL("FS"),12)]"" D
... S NCLI=$P($P(NSEG(NC),HL("FS"),12),NS,2)
... S:'NCLI NCLI=$O(^SC("B",$P($P(NSEG(NC),HL("FS"),12),NS),0))
... S:NCLI PDL(5)=+$P($G(^SC(NCLI,0)),"^",15)
... S N19=NDFN_"-"_$S(NSA]"":NSA_"S",1:NCLI),PDL(9)=N19 S:NCLI PDL(8)=NCLI
... S $P(NSEG(NC),HL("FS"),20)=N19
.. I $P(NSEG(NC),HL("FS"),4)]"" D
... S NWDI=$O(^DIC(42,"B",$P($P(NSEG(NC),HL("FS"),4),NS),0))
... I NWDI S PDL(7)=NWDI S:'$G(PDL(5)) PDL(5)=+$P($G(^DIC(42,NWDI,0)),"^",11)
.. S:$P(NSEG(NC),HL("FS"),51)]"" PDL(6)=$P(NSEG(NC),HL("FS"),51)
Q
;
GETPSARS(PSYSIN,DFNIN,FILTER) ; Return Send Area for all clinic orders for patient DFN
; OUTPUT: ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"CL",CLINICIEN,SENDAREAIEN)=PCLSAS
; ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"SA",SENDAREAIEN,CLINICIEN)=PCLSAS
; PCLSAS=Send Area Name^PADE System^Division^Clinic Name^Source of Send Area value
; INPUT
; PSYSIN (required) - PADE System IEN from File #58.7
; FILTER (optional) - 0: No filter
; 1: INCLUDE CLINIC IN BG JOB required (set to YES).
; 2: RE-SEND ORDERS AT CHECK-IN required (set to YES)
; 3: Both INCLUDE CLINIC IN BG JOB and RE-SEND ORDERS AT CHECK-IN required (set to YES)
;
Q:'$G(PSYSIN)
N ND,CLIN,DFN,DIVISION
S FILTER=+$G(FILTER)
;
K ^TMP("PS",$J),^TMP($J,"PSJCLSA") S CNT=0
S DFN=DFNIN
D OCL1^PSJORRE(DFN,"","",0)
Q:'$D(^TMP("PS",$J))
;
N PSJORD,CLINICA
S I=0 F S I=$O(^TMP("PS",$J,I)) Q:'I D
. N CLINICI,IENS
. S J=^TMP("PS",$J,I,0),PSJORD=$P(J,"^")
. Q:'((PSJORD["U"!(PSJORD["V")&($P(J,"^",9)="ACTIVE")))
. S IENS=+PSJORD_","_+DFN
. I PSJORD["U" S CLINICI=$$GET1^DIQ(55.06,IENS,130,"I")
. I PSJORD["V" S CLINICI=$$GET1^DIQ(55.01,IENS,136,"I")
. Q:'$G(CLINICI)
. S DIVISION=$$GET1^DIQ(44,CLINICI,3.5,"I")
. Q:'$G(DIVISION)
. S CLINICA(DIVISION,CLINICI)=""
Q:'$O(CLINICA(""))
;
S DIVISION=0 F S DIVISION=$O(CLINICA(DIVISION)) Q:'DIVISION D
. S CLINICA=0 F S CLINICA=$O(CLINICA(DIVISION,CLINICA)) Q:'CLINICA D TMPSA(PSYSIN,DIVISION,CLINICA,FILTER)
;
Q
GETDSARS(PSYSIN,PDIVIN,FILTER) ; Return Send Area for all clinics in Division PDIVIN
; OUTPUT: ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"CL",CLINICIEN,SENDAREAIEN)=PCLSAS
; ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"SA",SENDAREAIEN,CLINICIEN)=PCLSAS
; PCLSAS=Send Area Name^PADE System^Division^Clinic Name^Source of Send Area value
; INPUT
; PSYSIN (required) - PADE System IEN from File #58.7
; PDIVIN (required) - PADE Division from File #58.7
; FILTER (optional) - 0: No filter
; 1: INCLUDE CLINIC IN BG JOB required (set to YES).
; 2: RE-SEND ORDERS AT CHECK-IN required (set to YES)
; 3: Both INCLUDE CLINIC IN BG JOB and RE-SEND ORDERS AT CHECK-IN required (set to YES)
;
Q:'$G(PSYSIN)!'$G(PDIVIN)
N ND,CLIN
S FILTER=+$G(FILTER)
;
S CLIN=0 F S CLIN=$O(^SC(CLIN)) Q:'CLIN D
. D TMPSA(PSYSIN,PDIVIN,CLIN,FILTER)
Q
;
TMPSA(PSYSIN,PDIVIN,CLIN,FILTER) ; Build ^TMP( for clinic CLIN
N PCLSAS
S ND=^SC(CLIN,0) Q:$P(ND,"^",3)'="C" Q:$P(ND,"^",15)'=PDIVIN ; Different Division
I $D(^SC(CLIN,"I")) S X=$G(^SC(CLIN,"I")) I $P(X,"^"),$P(X,"^",2)'>$P(X,"^") Q ; Inactive Clinic
S PCLSAS=$$GETSAR(PSYSIN,PDIVIN,CLIN,FILTER)
I $L($P(PCLSAS,"^"))>1 S PCLSAS(PSYSIN,PDIVIN,CLIN)=PCLSAS D
. N SNDAREA,SNDAREAI S SNDAREA=$P(PCLSAS,"^"),SNDAREAI=$P(PCLSAS,"^",6)
. S ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"CL",CLIN,SNDAREAI)=PCLSAS
. S ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"SA",SNDAREAI,CLIN)=PCLSAS
Q
;
GETSAR(PSYSIN,PDIVIN,PCLININ,FILTER) ; Return Send Area for clinic PCLIN
; PSYS - PADE system from PADE SYSTEM SETUP (#58.7)
; PDIV - Division from PADE SYSTEM SETUP (#58.7) (pointer to MEDICAL CENTER DIVISION #40.8)
; PSNDAR - Send Area from PADE SYSTEM SETUP (58.7) associated with the lowest (most specific/granular) clinic parameter
;
I '$G(PSYSIN)!'$G(PDIVIN)!'$G(PCLININ) Q 0
N PSJSAR,PSJSARI,PSJQ,PCLINAM,PSADIVDF,PSADIVDFI,PSJRESND,PSJBGJOB,PSJRESNDD,PSJBGJOBD,PSJNORES
N PSJPSARI
;
S PSJQ="" ; Return values
S PSADIVDF="" ; Default Divisional Send Area Name
S PSADIVDFI="" ; Default Divisional Send Area IEN
S PSJRESND="" ; RE-SEND ORDERS AT CHECK-IN flag for clinic/clinic group
S PSJRESNDD="" ; RE-SEND ORDERS AT CHECK-IN Divisional default (or System default if Div is null)
S PSJBGJOB="" ; INCLUDE CLINIC IN BG JOB flag for clinic/clinic group
S PSJBGJOBD="" ; INCLUDE CLINIC IN BG JOB flag Divisional default (or System default if Div is null)
;
S PCLINAM=$P($G(^SC(+PCLININ,0)),"^")
;
N DN S DN=$G(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)) Q:DN="" 0
N DC S DC=$P(DN,"^",2)
I DC&(DC<DT) Q 0 ;DIV INACTIVE
;
; RE-SEND ORDERS AT CHECK-IN (default - if not defined at lower level)
S PSJRESNDD=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",10)
I PSJRESNDD="" S PSJRESNDD=$P($G(^PS(58.7,PSYSIN,1)),"^",3)
;
; INCLUDE ALL CLINICS IN BG JOB? (default - if not defined at lower level)
S PSJBGJOBD=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",9)
S PSJBGJOBD=$S(PSJBGJOBD="Y":1,PSJBGJOBD="N":0,1:"")
;
; Get Divisional/System default Send Area if not filtered
I ($P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",3)="Y")&($P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,2)),"^",1)="Y") D
. S PSADIVDFI=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",4)
. S:PSADIVDFI PSADIVDF=$P($G(^PS(58.71,PSADIVDFI,0)),"^")
;
; Get CLINIC default Send Area if not filtered
S PSJSARI=$O(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL","B",PCLININ,0))
I PSJSARI D
. I ($G(FILTER)=2)!($G(FILTER)=3) D Q:'$G(PSJRESND)
.. S PSJRESND=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL",PSJSARI,0)),"^",4)
.. S:PSJRESND="" PSJRESND=PSJRESNDD
. I ($G(FILTER)=1)!($G(FILTER)=3) D Q:'$G(PSJBGJOB)
.. S PSJBGJOB=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL",PSJSARI,0)),"^",3)
.. S PSJBGJOB=$S(PSJBGJOB="Y":1,1:PSJBGJOBD) ; Choices=YES or NULL
.. S:PSJBGJOB PSJBGJOBD=PSJBGJOB ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
. S PSJSARI=+$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL",PSJSARI,0)),"^",2)
. S PSJSAR=$P($G(^PS(58.71,+PSJSARI,0)),"^")
. S PSJQ=PSJSAR_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^CL^"_PSJSARI
Q:$L(PSJQ) PSJQ
Q:(PSJRESND=0) "" ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
;
; Get PADE CLINIC GROUP Send Area if not filtered
S PSJSARI=$O(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG","C",PCLININ,0))
I PSJSARI D
. I ($G(FILTER)=2)!($G(FILTER)=3) D Q:'$G(PSJRESND)
.. S PSJRESND=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG",PSJSARI,2)),"^",2)
.. S:PSJRESND="" PSJRESND=PSJRESNDD
. I ($G(FILTER)=1)!($G(FILTER)=3) D Q:'$G(PSJBGJOB)
.. S PSJBGJOB=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG",PSJSARI,2)),"^")
.. S PSJBGJOB=$S(PSJBGJOB="Y":1,1:PSJBGJOBD) ; Choices=YES or NULL
.. S:PSJBGJOB PSJBGJOBD=PSJBGJOB ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
. S PSJSARI=+$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG",PSJSARI,0)),"^",2)
. S PSJSAR=$P($G(^PS(58.71,+PSJSARI,0)),"^")
. S PSJQ=PSJSAR_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^PCG^"_PSJSARI
Q:$L(PSJQ) PSJQ
Q:(PSJRESND=0) "" ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
;
; Get VISTA CLINIC GROUP Send Area if not filtered
I $O(^PS(57.8,"AC",PCLININ,0)) D
. S PSJSARI=$O(^PS(57.8,"AC",PCLININ,0))
. I PSJSARI S PSJSARI=$O(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG","B",PSJSARI,0))
. Q:'PSJSARI
. I ($G(FILTER)=2)!($G(FILTER)=3) D Q:'$G(PSJRESND)
.. S PSJRESND=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG",PSJSARI,0)),"^",4)
.. S:PSJRESND="" PSJRESND=PSJRESNDD
. I ($G(FILTER)=1)!($G(FILTER)=3) D Q:'$G(PSJBGJOB)
.. S PSJBGJOB=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG",PSJSARI,0)),"^",3)
.. S PSJBGJOB=$S(PSJBGJOB="Y":1,1:PSJBGJOBD) ; Choices=YES or NULL
.. S:PSJBGJOB PSJBGJOBD=PSJBGJOB ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
. S PSJSARI=+$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG",PSJSARI,0)),"^",2)
. S PSJSAR=$P($G(^PS(58.71,PSJSARI,0)),"^")
. S PSJQ=PSJSAR_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^VCG^"_PSJSARI
Q:$L(PSJQ) PSJQ
Q:(PSJRESND=0) "" ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
;
; Get WILDCARD CLINIC NAME Send Area if not filtered
S PSJPSARI=$O(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN","B",0)) I PSJPSARI'="" D
. N PSJWC,PSJLEN S PSJWC="" F S PSJWC=$O(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN","B",PSJWC)) Q:PSJWC="" D
.. I $E(PCLINAM,1,$L(PSJWC))=PSJWC S PSJLEN($L(PSJWC),PSJWC)=""
. I $D(PSJLEN) D
.. S PSJPSARI=$O(PSJLEN(999),-1)
.. S PSJPSARI=$O(PSJLEN(PSJPSARI,0))
.. S PSJPSARI=+$O(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN","B",PSJPSARI,0))
.. S PSJSARI=+$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN",PSJPSARI,0)),"^",2)
.. S PSJSAR=$P($G(^PS(58.71,PSJSARI,0)),"^")
. I ($G(FILTER)=2)!($G(FILTER)=3) D Q:'$G(PSJRESND)
.. S PSJRESND=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN",PSJPSARI,0)),"^",4)
.. S:PSJRESND="" PSJRESND=PSJRESNDD
. I ($G(FILTER)=1)!($G(FILTER)=3) D Q:'$G(PSJBGJOB)
.. S PSJBGJOB=$P($G(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN",PSJPSARI,0)),"^",3)
.. S PSJBGJOB=$S(PSJBGJOB="Y":1,1:PSJBGJOBD) ; Choices=YES or NULL
.. S:PSJBGJOB PSJBGJOBD=PSJBGJOB ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
. S PSJQ=$G(PSJSAR)_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^WCN^"_PSJSARI
Q:$L(PSJQ) PSJQ
Q:(PSJRESND=0) "" ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
;
; If no matches, use Division default. PSADIVDF only defined if SEND MESSAGES FOR ALL CLINICS? and SEND ORDER MESSAGES? set to YES
; and Divisional default SEND AREA exists.
I $L($G(PSADIVDF)) D
. I ($G(FILTER)=2)!($G(FILTER)=3) Q:'$G(PSJRESNDD)
. I ($G(FILTER)=1)!($G(FILTER)=3) Q:'$G(PSJBGJOBD)
. S PSJQ=PSADIVDF_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^DIVDFLT^"_PSADIVDFI
Q PSJQ
;
KILLTMP ; Clean up ^TMP($J,"PSJCLSA")
K ^TMP($J,"PSJCLSA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDAPP 15347 printed Dec 13, 2024@02:08:40 Page 2
PSJPDAPP ;BIR/MHA - SEND APPOINTMENTS TO PADE ;11/27/15
+1 ;;5.0;INPATIENT MEDICATIONS;**317,389,415,432**;16 DEC 97;Build 18
+2 ;Reference to ^PS(55 is supported by DBIA 2191
+3 ;Reference to ^ORD(101 supported by DBIA 872
+4 ;Reference to GETPLIST^SDAMA202 supported by DBIA 3869
+5 ;Reference to ^SC supported by DBIA 10040
+6 ;Reference to ^DPT supported by DBIA 10035
+7 QUIT
+8 ;
EN ;
+1 NEW PDA,PDCL,PDCLA,PDI,PDJ,PDK,PSJAP,PSJCLPD,PSJPDNM,PSJDIV,DTP,SA,SEQ,I,J,K,L,P,X,Y,Z,PSJNIP,X1,X2
+2 SET (DTP,PSJAP,I)=0
+3 KILL ^TMP($JOB,"PSJCLSA")
+4 FOR
SET I=$ORDER(^PS(58.7,I))
if 'I
QUIT
SET J=$$PDACT^PSJPDCLA(I)
+5 if 'PSJAP
QUIT
+6 SET I=0
FOR
SET I=$ORDER(PSJAP(I))
if 'I
QUIT
Begin DoDot:1
+7 SET DTP=+$GET(^PS(58.7,I,1))
+8 SET J=0
FOR
SET J=$ORDER(^PS(58.7,I,"DIV",J))
if 'J
QUIT
Begin DoDot:2
+9 SET Y=$GET(^PS(58.7,I,"DIV",J,0))
IF Y=""!($PIECE(Y,"^",2)&($PIECE(Y,"^",2)<DT))
QUIT
+10 SET SA=""
+11 ;send appt for all clinics
IF $PIECE(Y,"^",9)="Y"
if $PIECE(Y,"^",4)
SET SA=$PIECE($GET(^PS(58.71,$PIECE(Y,"^",4),0)),"^")
DO ALLCLN
+12 DO CLARR
+13 ; Get all CLINIC to SEND AREA associations, where
+14 ; INCLUDE CLINICS IN BG JOB and RE-SEND ORDERS AT CHECK-IN evaluates to YES
+15 DO GETDSARS^PSJPDAPP(I,J,3)
End DoDot:2
End DoDot:1
+16 MERGE PDCL=PDCLA
+17 IF '$DATA(PDCL)
DO KILLTMP
QUIT
+18 NEW SNM,CNM
SET SNM="PSJ SIU-S12 SERVER"
SET CNM="PSJ SIU-S12 CLIENT"
+19 IF '$ORDER(^ORD(101,"B",SNM,0))!('$ORDER(^ORD(101,"B",CNM,0)))
QUIT
+20 NEW NHL
DO INIT^HLFNC2(SNM,.NHL)
if $DATA(NHL)=1
QUIT
+21 NEW NFS,NECH,HL,HLFS,NSEG,EDT,APT,DFN,PSJDTM,PSJND,PSJVP,PSJVNM,PSJDNS,PSJDNM,PSJOR,PSJORN
+22 MERGE HL=NHL
SET (NFS,HLFS)=HL("FS")
SET NECH=$EXTRACT(HL("ECH"),1)
+23 SET PDI=0
FOR
SET PDI=$ORDER(PDCL(PDI))
if 'PDI
QUIT
Begin DoDot:1
+24 SET PSJND=$GET(^PS(58.7,PDI,0))
+25 SET PSJVNM=$PIECE(PSJND,"^")
SET PSJDNS=$PIECE(PSJND,"^",2)
SET PSJVP=$PIECE(PSJND,"^",3)
+26 SET PDJ=0
FOR
SET PDJ=$ORDER(PDCL(PDI,PDJ))
if 'PDJ
QUIT
Begin DoDot:2
+27 SET PSJDNM=$PIECE($$SITE^VASITE(,PDJ),"^",3)
+28 SET PDK=0
FOR
SET PDK=$ORDER(PDCL(PDI,PDJ,PDK))
if 'PDK
QUIT
DO APPT
End DoDot:2
End DoDot:1
+29 DO KILLTMP
+30 QUIT
+31 ;
APPT ;
+1 KILL ^TMP($JOB,"SDAMA202")
+2 SET PSJOR=PDK
SET PSJORN=$PIECE(^SC(PDK,0),"^")
+3 SET DTP=PDCL(PDI,PDJ,PDK)
+4 SET EDT=DT
+5 IF DTP
SET X1=DT
SET X2=+DTP
DO C^%DTC
SET EDT=X
+6 DO GETPLIST^SDAMA202(PDK,"1;4","",DT,EDT)
+7 if '$DATA(^TMP($JOB,"SDAMA202"))
QUIT
+8 KILL APDTM,CLNM,PSJXCL
+9 SET PDA=0
FOR
SET PDA=$ORDER(^TMP($JOB,"SDAMA202","GETPLIST",PDA))
if 'PDA
QUIT
Begin DoDot:1
+10 SET PSJDTM=+^TMP($JOB,"SDAMA202","GETPLIST",PDA,1)
+11 SET DFN=+^TMP($JOB,"SDAMA202","GETPLIST",PDA,4)
+12 if $PIECE($GET(^DPT(DFN,.1)),"^")]""&($PIECE(^PS(58.7,PDI,0),"^",6)'="Y")
QUIT
+13 KILL NSEG
NEW ZZ1,XX,FTS
SET (ZZ1,FTS)=""
SET PSJNIP=0
+14 IF $PIECE($GET(^DPT(DFN,.1)),"^")]""
Begin DoDot:2
+15 DO IN5^VADPT
+16 NEW PSJQ,PSJWD,PSJRBD
+17 SET PSJWD=$PIECE(VAIP(5),"^",2)
SET PSJRBD=$PIECE(VAIP(6),"^",2)
+18 SET PSJQ=$$CHKPD^PSJPDCL(PSJWD,PSJRBD)
+19 IF 'PSJQ
SET PSJNIP=1
QUIT
+20 SET FTS=$PIECE(VAIP(8),"^")_NECH_$PIECE(VAIP(8),"^",2)
+21 SET XX=0
FOR
SET XX=$ORDER(PSJQ(XX))
if 'XX
QUIT
Begin DoDot:3
+22 IF XX=PDI
IF $PIECE(PSJQ(XX),"^",2)'=""
SET ZZ1=$PIECE(PSJQ(XX),"^",2)
+23 IF XX'=PDI
SET PSJNIP=1
+24 IF $GET(PSJXCL(PDI))
SET PSJNIP=0
End DoDot:3
End DoDot:2
+25 SET SEQ=0
DO SRBLD^PSJPDCLA
MERGE HL=NHL
NEW ZZ2
SET ZZ2=$SELECT($PIECE(DTP,"^",2)'="":$PIECE(DTP,"^",2),1:"")
+26 SET SEQ=SEQ+1
SET NSEG(SEQ)="ZZZ"_HL("FS")_$SELECT(ZZ1'="":ZZ1,1:"")_HL("FS")_ZZ2_HL("FS")_FTS
+27 KILL HLP,HLA,PSJSND
SET HLP=""
SET HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
+28 NEW XX
SET XX=PDI
DO PV19
MERGE HLA("HLS")=NSEG
+29 DO GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
+30 DO LOG^PSJPADE
+31 ;check for O11 re-send
+32 ; Resend all orders for the input CLINIC's SEND AREA
DO RESNDORDS^PSJPDCLA(DFN,PSJOR,PDJ,PDI,3)
End DoDot:1
+33 QUIT
+34 ;
ALLCLN ;
+1 NEW ND
SET Z=0
FOR
SET Z=$ORDER(^SC(Z))
if 'Z
QUIT
Begin DoDot:1
+2 SET ND=^SC(Z,0)
if $PIECE(ND,"^",3)'="C"
QUIT
if $PIECE(ND,"^",15)'=J
QUIT
+3 IF $DATA(^SC(Z,"I"))
SET X=$GET(^SC(Z,"I"))
IF $PIECE(X,"^")
IF $PIECE(X,"^",2)'>$PIECE(X,"^")
QUIT
+4 SET PDCL(I,J,Z)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:1
+5 QUIT
+6 ;
CLARR ;
+1 SET Z=0
SET SA=""
+2 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"CL",Z))
if 'Z
QUIT
SET K=^PS(58.7,I,"DIV",J,"CL",Z,0)
if $PIECE(K,"^",3)="Y"
Begin DoDot:1
+3 SET SA=$PIECE(K,"^",2)
+4 if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+5 SET PDCLA(I,J,+K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:1
+6 SET Z=0
+7 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"PCG",Z))
if 'Z
QUIT
if $PIECE($GET(^PS(58.7,I,"DIV",J,"PCG",Z,2)),"^")="Y"
Begin DoDot:1
+8 SET SA=$PIECE($GET(^PS(58.7,I,"DIV",J,"PCG",Z,0)),"^",2)
+9 if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+10 SET X=0
FOR
SET X=$ORDER(^PS(58.7,I,"DIV",J,"PCG",Z,1,X))
if 'X
QUIT
Begin DoDot:2
+11 SET K=+$GET(^PS(58.7,I,"DIV",J,"PCG",Z,1,X,0))
+12 IF '$DATA(PDCLA(I,J,K))
SET PDCLA(I,J,K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:2
End DoDot:1
+13 SET Z=0
+14 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"VCG",Z))
if 'Z
QUIT
SET X=^PS(58.7,I,"DIV",J,"VCG",Z,0)
if $PIECE(X,"^",3)="Y"
Begin DoDot:1
+15 SET SA=$PIECE(X,"^",2)
if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+16 SET Y=0
FOR
SET Y=$ORDER(^PS(57.8,+X,1,Y))
if 'Y
QUIT
Begin DoDot:2
+17 SET K=+^(Y,0)
if '$DATA(PDCLA(I,J,K))
SET PDCLA(I,J,K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:2
End DoDot:1
+18 SET Z=0
SET L=""
+19 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"WCN",Z))
if 'Z
QUIT
SET X=^PS(58.7,I,"DIV",J,"WCN",Z,0)
if $PIECE(X,"^",3)="Y"
Begin DoDot:1
+20 SET SA=$PIECE(X,"^",2)
if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+21 SET Y=$PIECE(X,"^")
SET P=$EXTRACT(X,1,$LENGTH(Y)-1)
FOR
SET P=$ORDER(^SC("B",P))
if P=""
QUIT
Begin DoDot:2
+22 ;p415
if ($EXTRACT(P,1,$LENGTH(Y))'=Y)
QUIT
+23 SET K=$ORDER(^SC("B",P,0))
SET L=$GET(^SC(K,0))
if $PIECE(L,"^",3)'="C"
QUIT
if $PIECE(L,"^",15)'=J
QUIT
+24 if '$DATA(PDCLA(I,J,K))
SET PDCLA(I,J,K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
PV19 ;
+1 NEW NC,NDFN,NCLI,N19,NSA,NS,NWDI,NQ
+2 SET (NSA,N19)=""
SET (NQ,NC)=0
SET NS=$EXTRACT(HL("ECH"),1)
SET PDL(10)=XX
SET PDL(4)=HL("ETN")
+3 if ZZ2]""
SET (NSA,PDL(12))=$ORDER(^PS(58.71,"B",ZZ2,0))
+4 if ZZ1]""
SET PDL(11)=$ORDER(^PS(58.71,"B",ZZ1,""))
+5 FOR
SET NC=$ORDER(NSEG(NC))
if 'NC
QUIT
Begin DoDot:1
+6 IF $EXTRACT(NSEG(NC),1,3)="PID"
SET (NDFN,PDL(1))=+$PIECE(NSEG(NC),HL("FS"),4)
QUIT
+7 IF $EXTRACT(NSEG(NC),1,3)="PV1"
Begin DoDot:2
+8 IF $PIECE(NSEG(NC),HL("FS"),12)]""
Begin DoDot:3
+9 SET NCLI=$PIECE($PIECE(NSEG(NC),HL("FS"),12),NS,2)
+10 if 'NCLI
SET NCLI=$ORDER(^SC("B",$PIECE($PIECE(NSEG(NC),HL("FS"),12),NS),0))
+11 if NCLI
SET PDL(5)=+$PIECE($GET(^SC(NCLI,0)),"^",15)
+12 SET N19=NDFN_"-"_$SELECT(NSA]"":NSA_"S",1:NCLI)
SET PDL(9)=N19
if NCLI
SET PDL(8)=NCLI
+13 SET $PIECE(NSEG(NC),HL("FS"),20)=N19
End DoDot:3
+14 IF $PIECE(NSEG(NC),HL("FS"),4)]""
Begin DoDot:3
+15 SET NWDI=$ORDER(^DIC(42,"B",$PIECE($PIECE(NSEG(NC),HL("FS"),4),NS),0))
+16 IF NWDI
SET PDL(7)=NWDI
if '$GET(PDL(5))
SET PDL(5)=+$PIECE($GET(^DIC(42,NWDI,0)),"^",11)
End DoDot:3
+17 if $PIECE(NSEG(NC),HL("FS"),51)]""
SET PDL(6)=$PIECE(NSEG(NC),HL("FS"),51)
End DoDot:2
SET NQ=1
QUIT
End DoDot:1
if NQ
QUIT
+18 QUIT
+19 ;
GETPSARS(PSYSIN,DFNIN,FILTER) ; Return Send Area for all clinic orders for patient DFN
+1 ; OUTPUT: ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"CL",CLINICIEN,SENDAREAIEN)=PCLSAS
+2 ; ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"SA",SENDAREAIEN,CLINICIEN)=PCLSAS
+3 ; PCLSAS=Send Area Name^PADE System^Division^Clinic Name^Source of Send Area value
+4 ; INPUT
+5 ; PSYSIN (required) - PADE System IEN from File #58.7
+6 ; FILTER (optional) - 0: No filter
+7 ; 1: INCLUDE CLINIC IN BG JOB required (set to YES).
+8 ; 2: RE-SEND ORDERS AT CHECK-IN required (set to YES)
+9 ; 3: Both INCLUDE CLINIC IN BG JOB and RE-SEND ORDERS AT CHECK-IN required (set to YES)
+10 ;
+11 if '$GET(PSYSIN)
QUIT
+12 NEW ND,CLIN,DFN,DIVISION
+13 SET FILTER=+$GET(FILTER)
+14 ;
+15 KILL ^TMP("PS",$JOB),^TMP($JOB,"PSJCLSA")
SET CNT=0
+16 SET DFN=DFNIN
+17 DO OCL1^PSJORRE(DFN,"","",0)
+18 if '$DATA(^TMP("PS",$JOB))
QUIT
+19 ;
+20 NEW PSJORD,CLINICA
+21 SET I=0
FOR
SET I=$ORDER(^TMP("PS",$JOB,I))
if 'I
QUIT
Begin DoDot:1
+22 NEW CLINICI,IENS
+23 SET J=^TMP("PS",$JOB,I,0)
SET PSJORD=$PIECE(J,"^")
+24 if '((PSJORD["U"!(PSJORD["V")&($PIECE(J,"^",9)="ACTIVE")))
QUIT
+25 SET IENS=+PSJORD_","_+DFN
+26 IF PSJORD["U"
SET CLINICI=$$GET1^DIQ(55.06,IENS,130,"I")
+27 IF PSJORD["V"
SET CLINICI=$$GET1^DIQ(55.01,IENS,136,"I")
+28 if '$GET(CLINICI)
QUIT
+29 SET DIVISION=$$GET1^DIQ(44,CLINICI,3.5,"I")
+30 if '$GET(DIVISION)
QUIT
+31 SET CLINICA(DIVISION,CLINICI)=""
End DoDot:1
+32 if '$ORDER(CLINICA(""))
QUIT
+33 ;
+34 SET DIVISION=0
FOR
SET DIVISION=$ORDER(CLINICA(DIVISION))
if 'DIVISION
QUIT
Begin DoDot:1
+35 SET CLINICA=0
FOR
SET CLINICA=$ORDER(CLINICA(DIVISION,CLINICA))
if 'CLINICA
QUIT
DO TMPSA(PSYSIN,DIVISION,CLINICA,FILTER)
End DoDot:1
+36 ;
+37 QUIT
GETDSARS(PSYSIN,PDIVIN,FILTER) ; Return Send Area for all clinics in Division PDIVIN
+1 ; OUTPUT: ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"CL",CLINICIEN,SENDAREAIEN)=PCLSAS
+2 ; ^TMP($J,"PSJCLSA",PSYSIN,PDIVIN,"SA",SENDAREAIEN,CLINICIEN)=PCLSAS
+3 ; PCLSAS=Send Area Name^PADE System^Division^Clinic Name^Source of Send Area value
+4 ; INPUT
+5 ; PSYSIN (required) - PADE System IEN from File #58.7
+6 ; PDIVIN (required) - PADE Division from File #58.7
+7 ; FILTER (optional) - 0: No filter
+8 ; 1: INCLUDE CLINIC IN BG JOB required (set to YES).
+9 ; 2: RE-SEND ORDERS AT CHECK-IN required (set to YES)
+10 ; 3: Both INCLUDE CLINIC IN BG JOB and RE-SEND ORDERS AT CHECK-IN required (set to YES)
+11 ;
+12 if '$GET(PSYSIN)!'$GET(PDIVIN)
QUIT
+13 NEW ND,CLIN
+14 SET FILTER=+$GET(FILTER)
+15 ;
+16 SET CLIN=0
FOR
SET CLIN=$ORDER(^SC(CLIN))
if 'CLIN
QUIT
Begin DoDot:1
+17 DO TMPSA(PSYSIN,PDIVIN,CLIN,FILTER)
End DoDot:1
+18 QUIT
+19 ;
TMPSA(PSYSIN,PDIVIN,CLIN,FILTER) ; Build ^TMP( for clinic CLIN
+1 NEW PCLSAS
+2 ; Different Division
SET ND=^SC(CLIN,0)
if $PIECE(ND,"^",3)'="C"
QUIT
if $PIECE(ND,"^",15)'=PDIVIN
QUIT
+3 ; Inactive Clinic
IF $DATA(^SC(CLIN,"I"))
SET X=$GET(^SC(CLIN,"I"))
IF $PIECE(X,"^")
IF $PIECE(X,"^",2)'>$PIECE(X,"^")
QUIT
+4 SET PCLSAS=$$GETSAR(PSYSIN,PDIVIN,CLIN,FILTER)
+5 IF $LENGTH($PIECE(PCLSAS,"^"))>1
SET PCLSAS(PSYSIN,PDIVIN,CLIN)=PCLSAS
Begin DoDot:1
+6 NEW SNDAREA,SNDAREAI
SET SNDAREA=$PIECE(PCLSAS,"^")
SET SNDAREAI=$PIECE(PCLSAS,"^",6)
+7 SET ^TMP($JOB,"PSJCLSA",PSYSIN,PDIVIN,"CL",CLIN,SNDAREAI)=PCLSAS
+8 SET ^TMP($JOB,"PSJCLSA",PSYSIN,PDIVIN,"SA",SNDAREAI,CLIN)=PCLSAS
End DoDot:1
+9 QUIT
+10 ;
GETSAR(PSYSIN,PDIVIN,PCLININ,FILTER) ; Return Send Area for clinic PCLIN
+1 ; PSYS - PADE system from PADE SYSTEM SETUP (#58.7)
+2 ; PDIV - Division from PADE SYSTEM SETUP (#58.7) (pointer to MEDICAL CENTER DIVISION #40.8)
+3 ; PSNDAR - Send Area from PADE SYSTEM SETUP (58.7) associated with the lowest (most specific/granular) clinic parameter
+4 ;
+5 IF '$GET(PSYSIN)!'$GET(PDIVIN)!'$GET(PCLININ)
QUIT 0
+6 NEW PSJSAR,PSJSARI,PSJQ,PCLINAM,PSADIVDF,PSADIVDFI,PSJRESND,PSJBGJOB,PSJRESNDD,PSJBGJOBD,PSJNORES
+7 NEW PSJPSARI
+8 ;
+9 ; Return values
SET PSJQ=""
+10 ; Default Divisional Send Area Name
SET PSADIVDF=""
+11 ; Default Divisional Send Area IEN
SET PSADIVDFI=""
+12 ; RE-SEND ORDERS AT CHECK-IN flag for clinic/clinic group
SET PSJRESND=""
+13 ; RE-SEND ORDERS AT CHECK-IN Divisional default (or System default if Div is null)
SET PSJRESNDD=""
+14 ; INCLUDE CLINIC IN BG JOB flag for clinic/clinic group
SET PSJBGJOB=""
+15 ; INCLUDE CLINIC IN BG JOB flag Divisional default (or System default if Div is null)
SET PSJBGJOBD=""
+16 ;
+17 SET PCLINAM=$PIECE($GET(^SC(+PCLININ,0)),"^")
+18 ;
+19 NEW DN
SET DN=$GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,0))
if DN=""
QUIT 0
+20 NEW DC
SET DC=$PIECE(DN,"^",2)
+21 ;DIV INACTIVE
IF DC&(DC<DT)
QUIT 0
+22 ;
+23 ; RE-SEND ORDERS AT CHECK-IN (default - if not defined at lower level)
+24 SET PSJRESNDD=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",10)
+25 IF PSJRESNDD=""
SET PSJRESNDD=$PIECE($GET(^PS(58.7,PSYSIN,1)),"^",3)
+26 ;
+27 ; INCLUDE ALL CLINICS IN BG JOB? (default - if not defined at lower level)
+28 SET PSJBGJOBD=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",9)
+29 SET PSJBGJOBD=$SELECT(PSJBGJOBD="Y":1,PSJBGJOBD="N":0,1:"")
+30 ;
+31 ; Get Divisional/System default Send Area if not filtered
+32 IF ($PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",3)="Y")&($PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,2)),"^",1)="Y")
Begin DoDot:1
+33 SET PSADIVDFI=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,0)),"^",4)
+34 if PSADIVDFI
SET PSADIVDF=$PIECE($GET(^PS(58.71,PSADIVDFI,0)),"^")
End DoDot:1
+35 ;
+36 ; Get CLINIC default Send Area if not filtered
+37 SET PSJSARI=$ORDER(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL","B",PCLININ,0))
+38 IF PSJSARI
Begin DoDot:1
+39 IF ($GET(FILTER)=2)!($GET(FILTER)=3)
Begin DoDot:2
+40 SET PSJRESND=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL",PSJSARI,0)),"^",4)
+41 if PSJRESND=""
SET PSJRESND=PSJRESNDD
End DoDot:2
if '$GET(PSJRESND)
QUIT
+42 IF ($GET(FILTER)=1)!($GET(FILTER)=3)
Begin DoDot:2
+43 SET PSJBGJOB=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL",PSJSARI,0)),"^",3)
+44 ; Choices=YES or NULL
SET PSJBGJOB=$SELECT(PSJBGJOB="Y":1,1:PSJBGJOBD)
+45 ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
if PSJBGJOB
SET PSJBGJOBD=PSJBGJOB
End DoDot:2
if '$GET(PSJBGJOB)
QUIT
+46 SET PSJSARI=+$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"CL",PSJSARI,0)),"^",2)
+47 SET PSJSAR=$PIECE($GET(^PS(58.71,+PSJSARI,0)),"^")
+48 SET PSJQ=PSJSAR_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^CL^"_PSJSARI
End DoDot:1
+49 if $LENGTH(PSJQ)
QUIT PSJQ
+50 ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
if (PSJRESND=0)
QUIT ""
+51 ;
+52 ; Get PADE CLINIC GROUP Send Area if not filtered
+53 SET PSJSARI=$ORDER(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG","C",PCLININ,0))
+54 IF PSJSARI
Begin DoDot:1
+55 IF ($GET(FILTER)=2)!($GET(FILTER)=3)
Begin DoDot:2
+56 SET PSJRESND=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG",PSJSARI,2)),"^",2)
+57 if PSJRESND=""
SET PSJRESND=PSJRESNDD
End DoDot:2
if '$GET(PSJRESND)
QUIT
+58 IF ($GET(FILTER)=1)!($GET(FILTER)=3)
Begin DoDot:2
+59 SET PSJBGJOB=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG",PSJSARI,2)),"^")
+60 ; Choices=YES or NULL
SET PSJBGJOB=$SELECT(PSJBGJOB="Y":1,1:PSJBGJOBD)
+61 ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
if PSJBGJOB
SET PSJBGJOBD=PSJBGJOB
End DoDot:2
if '$GET(PSJBGJOB)
QUIT
+62 SET PSJSARI=+$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"PCG",PSJSARI,0)),"^",2)
+63 SET PSJSAR=$PIECE($GET(^PS(58.71,+PSJSARI,0)),"^")
+64 SET PSJQ=PSJSAR_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^PCG^"_PSJSARI
End DoDot:1
+65 if $LENGTH(PSJQ)
QUIT PSJQ
+66 ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
if (PSJRESND=0)
QUIT ""
+67 ;
+68 ; Get VISTA CLINIC GROUP Send Area if not filtered
+69 IF $ORDER(^PS(57.8,"AC",PCLININ,0))
Begin DoDot:1
+70 SET PSJSARI=$ORDER(^PS(57.8,"AC",PCLININ,0))
+71 IF PSJSARI
SET PSJSARI=$ORDER(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG","B",PSJSARI,0))
+72 if 'PSJSARI
QUIT
+73 IF ($GET(FILTER)=2)!($GET(FILTER)=3)
Begin DoDot:2
+74 SET PSJRESND=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG",PSJSARI,0)),"^",4)
+75 if PSJRESND=""
SET PSJRESND=PSJRESNDD
End DoDot:2
if '$GET(PSJRESND)
QUIT
+76 IF ($GET(FILTER)=1)!($GET(FILTER)=3)
Begin DoDot:2
+77 SET PSJBGJOB=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG",PSJSARI,0)),"^",3)
+78 ; Choices=YES or NULL
SET PSJBGJOB=$SELECT(PSJBGJOB="Y":1,1:PSJBGJOBD)
+79 ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
if PSJBGJOB
SET PSJBGJOBD=PSJBGJOB
End DoDot:2
if '$GET(PSJBGJOB)
QUIT
+80 SET PSJSARI=+$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"VCG",PSJSARI,0)),"^",2)
+81 SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSARI,0)),"^")
+82 SET PSJQ=PSJSAR_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^VCG^"_PSJSARI
End DoDot:1
+83 if $LENGTH(PSJQ)
QUIT PSJQ
+84 ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
if (PSJRESND=0)
QUIT ""
+85 ;
+86 ; Get WILDCARD CLINIC NAME Send Area if not filtered
+87 SET PSJPSARI=$ORDER(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN","B",0))
IF PSJPSARI'=""
Begin DoDot:1
+88 NEW PSJWC,PSJLEN
SET PSJWC=""
FOR
SET PSJWC=$ORDER(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN","B",PSJWC))
if PSJWC=""
QUIT
Begin DoDot:2
+89 IF $EXTRACT(PCLINAM,1,$LENGTH(PSJWC))=PSJWC
SET PSJLEN($LENGTH(PSJWC),PSJWC)=""
End DoDot:2
+90 IF $DATA(PSJLEN)
Begin DoDot:2
+91 SET PSJPSARI=$ORDER(PSJLEN(999),-1)
+92 SET PSJPSARI=$ORDER(PSJLEN(PSJPSARI,0))
+93 SET PSJPSARI=+$ORDER(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN","B",PSJPSARI,0))
+94 SET PSJSARI=+$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN",PSJPSARI,0)),"^",2)
+95 SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSARI,0)),"^")
End DoDot:2
+96 IF ($GET(FILTER)=2)!($GET(FILTER)=3)
Begin DoDot:2
+97 SET PSJRESND=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN",PSJPSARI,0)),"^",4)
+98 if PSJRESND=""
SET PSJRESND=PSJRESNDD
End DoDot:2
if '$GET(PSJRESND)
QUIT
+99 IF ($GET(FILTER)=1)!($GET(FILTER)=3)
Begin DoDot:2
+100 SET PSJBGJOB=$PIECE($GET(^PS(58.7,PSYSIN,"DIV",PDIVIN,"WCN",PSJPSARI,0)),"^",3)
+101 ; Choices=YES or NULL
SET PSJBGJOB=$SELECT(PSJBGJOB="Y":1,1:PSJBGJOBD)
+102 ; If INCLUDE=YES, use as default for this clinic (can't be overridden)
if PSJBGJOB
SET PSJBGJOBD=PSJBGJOB
End DoDot:2
if '$GET(PSJBGJOB)
QUIT
+103 SET PSJQ=$GET(PSJSAR)_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^WCN^"_PSJSARI
End DoDot:1
+104 if $LENGTH(PSJQ)
QUIT PSJQ
+105 ; RE-SEND ORDERS=NO for this clinic, filter=required, ignore higher Send Area values.
if (PSJRESND=0)
QUIT ""
+106 ;
+107 ; If no matches, use Division default. PSADIVDF only defined if SEND MESSAGES FOR ALL CLINICS? and SEND ORDER MESSAGES? set to YES
+108 ; and Divisional default SEND AREA exists.
+109 IF $LENGTH($GET(PSADIVDF))
Begin DoDot:1
+110 IF ($GET(FILTER)=2)!($GET(FILTER)=3)
if '$GET(PSJRESNDD)
QUIT
+111 IF ($GET(FILTER)=1)!($GET(FILTER)=3)
if '$GET(PSJBGJOBD)
QUIT
+112 SET PSJQ=PSADIVDF_"^"_PSYSIN_"^"_PDIVIN_"^"_PCLINAM_"^DIVDFLT^"_PSADIVDFI
End DoDot:1
+113 QUIT PSJQ
+114 ;
KILLTMP ; Clean up ^TMP($J,"PSJCLSA")
+1 KILL ^TMP($JOB,"PSJCLSA")
+2 QUIT
