- 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 Feb 18, 2025@23:35:03 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