PSJPDCLA ;BIR/MA/MC - PADE HL7 - CLINIC CHECK ;07/08/15
;;5.0;INPATIENT MEDICATIONS;**317,337,362,432**;16 DEC 97;Build 18
;Reference to EN^VAFCPID supported by DBIA 3015
;Reference to IN^VAFHLPV1 supported by DBIA 3018
;Reference to $$PIVCHK^VAFHPIVT supported by DBIA 6606
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^PS(52.6 supported by DBIA 1231
;Reference to ^PS(52.7 supported by DBIA 2173
;Reference to ^DIC(42 supported by DBIA 10039
;Reference to ^ORD(101 supported by DBIA 872
;Reference to ^SC supported by DBIA 10040
;Reference to ^DPT supported by DBIA 10035
;Reference to ^PSDRUG supported by DBIA 2192
;Reference to ^SRF supported by DBIA 103
;Reference to ^SRS supported by DBIA 3362
Q
;
EN ; Get SDAM Message and send to PADE.
Q:$G(SDAMEVT)'=4!($P($G(SDATA),"^",4)<1)
N PSJAP S PSJAP=0
EN1 ;
Q:'$P($$SEND^VAFHUTL(),"^",2)
Q:$O(^PS(58.7,"B",""))=""
N I,J S I=0
F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT(I)
Q:'PSJAP
Q:$G(PSJPA)
Q:'$G(HLEID)
I $G(HL("ETN"))="" D INIT^HLFNC2(HLEID,.HL) Q:$D(HL)=1
N FS,ECH S FS=HL("FS"),ECH=$E(HL("ECH"),1)
N SNM,CNM S SNM="PSJ SIU-S12 SERVER",CNM="PSJ SIU-S12 CLIENT"
Q:'$O(^ORD(101,"B",SNM,0))
Q:'$O(^ORD(101,"B",CNM,0))
D INIT^HLFNC2(SNM,.NHL) Q:$D(NHL)=1
N NFS,NECH,HLFS,HLECH,Y S (HLFS,NFS)=NHL("FS"),NECH=$E(NHL("ECH"),1)
N PSJX,PSJQ,NSEG,SEQ,PSJORN,PSJOR,PSJDTM,PSJDIV,PSJDNM,PSJPV50,PDL
S (PSJQ,SEQ)=0,PSJX=1,(PSJPV50,PSJORN)=""
F I=1:1 X HLNEXT Q:HLQUIT'>0!(PSJORN]"") D
. I $E(HLNODE,1,3)="PV1" S PSJORN=$P(HLNODE,FS,4),PSJPV50=$P(HLNODE,FS,51)
Q:PSJORN=""
D CHKINPF
Q:'$O(PSJAP(0))
N PSJBAP,FTS M PSJBAP=PSJAP
K NSEG N PSJQW,PSJNIP S PSJNIP=0,FTS=""
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
. M PSJQW=PSJQ
. S FTS=$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2)
M PSJAP=PSJBAP
K PSJQ S PSJQ=$$CHKPDCL(PSJORN)
Q:'PSJQ
S PSJDTM=$G(HLP("DT"))
S PSJOR=$O(^SC("B",PSJORN,0))
S PSJDIV=+$P($G(^SC(PSJOR,0)),"^",15)
S PSJDNM=$P($$SITE^VASITE(,PSJDIV),"^",3)
S ZTIO=""
S ZTRTN="CLCI^PSJPDCLA"
F XX="PSJPV50","PSJQ(","PSJOR","PSJORN","PSJDTM","PSJDIV","PSJDNM","DFN","PSJQW(","NHL(","SNM","CNM","FTS" S ZTSAVE(XX)=""
S ZTDESC="Send PADE HL7 Checkin Message"
S ZTDTH=$H
D ^%ZTLOAD
Q
;
CLCI ;
N XX,ZZ1 S XX=0 F S XX=$O(PSJQ(XX)) Q:'XX D
. S PSJND=$G(^PS(58.7,XX,0))
. S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
. S ZZ1="",PSJNIP=0
. ;I 'PSJNIP,$P(PSJND,"^",6)'="Y" Q
. I $P($G(^DPT(DFN,.1)),"^")]"",$P(PSJND,"^",6)'="Y" Q ;*362 - if inpatient and the flag SEND CHECKIN/SURG HL7 FOR INPT is not "Y" then quit
. I $D(PSJQW(XX)),$P(PSJQW(XX),"^",2)'="" S ZZ1=$P(PSJQW(XX),"^",2)
. I '$D(PSJQW(XX)) S PSJNIP=1
. S (HLFS,NFS)=NHL("FS"),NECH=$E(NHL("ECH"),1),HLECH=NHL("ECH")
. K NSEG S SEQ=0 N HL M HL=NHL D SRBLD N ZZ2 S ZZ2=$S($P(PSJQ(XX),"^",2)'="":$P(PSJQ(XX),"^",2),1:"")
. S SEQ=SEQ+1,NSEG(SEQ)="ZZZ"_HL("FS")_$S(ZZ1'="":ZZ1,1:"")_HL("FS")_ZZ2_HL("FS")_FTS
. K HLP,HLA S HLP="",HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
. D PV19^PSJPDAPP M HLA("HLS")=NSEG
. D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
. D LOG^PSJPADE
. ;check for O11 re-send
. D GETPSARS^PSJPDAPP(XX,DFN,3) ; Build PADE clinics/send areas per parameter info
. D RESNDORDS^PSJPDCLA(DFN,PSJOR,PSJDIV,XX,2) ; Resend all orders for the input CLINIC's SEND AREA
D KILLTMP^PSJPDAPP
Q
;
SEND ;
N XX,PSJND,PSJVNM,PSJDNS,PSJVP,VR,HLA,CT
M HLA("HLS")=NSEG
D INIT^HLFNC2(SNM,.HL) Q:$D(HL)=1
S XX=0,CT=$O(NSEG(9999),-1)+1
F S XX=$O(PSJQ(XX)) Q:'XX D ;sends HL7 message for each PADE SERVER
.S PSJND=$G(^PS(58.7,XX,0))
.Q:PSJND=""
.S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
.Q:PSJVNM=""!(PSJDNS="")!('PSJVP)
.N HLP,PSJSND S HLP=""
.S HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
.I '$D(HL) M HL=NHL
.N ZZ2,ZZ1 S ZZ2=$P(PSJQ(XX),"^",2)
.S ZZ1=$S($P($G(PSJQS(XX)),"^",2)]"":$P($G(PSJQS(XX)),"^",2),1:"")
.S NSEG(CT)="ZZZ"_HL("FS")_ZZ1_HL("FS")_ZZ2_HL("FS")_FTS
.D PV19^PSJPDAPP
.K HLA M HLA("HLS")=NSEG
.D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
.D LOG^PSJPADE
Q
;
TR(SEG) ; Translate the VAFC message delimiters to HL7 delimiters for PADE
N CSEG
S CSEG=$TR(SEG,HL("FS")_HL("ECH"),NHL("FS")_NHL("ECH"))
S CSEG=$TR(CSEG,"""","")
Q CSEG
;
PDACT(PSJPD) ;
Q:'$D(^PS(58.7,PSJPD,0)) 0
N PSJVNM,PSJDNS,PSJVP,PSJACT,PSJND S PSJND=$G(^PS(58.7,PSJPD,0))
S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
I PSJVNM=""!(PSJDNS="")!('PSJVP) Q 0
S PSJACT=$P(PSJND,"^",4)
I PSJACT&(PSJACT<DT) Q 0
S PSJAP(PSJPD)="",PSJAP=1
Q 1
;
CHKPDCL(PSJCL) ;
N PSJCLI S PSJCLI=$S($G(PSJPDO):PSJCL,1:$O(^SC("B",PSJCL,"")))
Q:'PSJCLI 0
N PSJDIV S PSJDIV=+$P($G(^SC(PSJCLI,0)),"^",15)
Q:'PSJDIV 0
S PSJCL=$P(^SC(PSJCLI,0),"^")
N PSJPD,PSJSAR S (PSJQ,PSJPD)=0
F S PSJPD=$O(^PS(58.7,"AD",PSJDIV,PSJPD)) Q:'PSJPD D
. Q:'$D(PSJAP(PSJPD))
. N DN S DN=$G(^PS(58.7,PSJPD,"DIV",PSJDIV,0)) Q:DN=""
. N DC S DC=$P(DN,"^",2)
. I DC&(DC<DT) Q ;DIV INACTIVE
. I $G(PSJPDO)=1 N I S I=0 D Q:I
.. I $P($G(^(2)),"^")'="Y" S I=1 Q ;DON'T SEND ORDER MESSAGES
.. I $G(RXO)["V",$P(DN,"^",7)'="Y" S I=1 Q ;DON'T SEND CLINIC IV
.. I $G(RXO)["V" I ($P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,3)),"^")="Y"),('$$CSIV) S I=1 Q ;CS ONLY
.. I $G(RXO)["U" I ($P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,3)),"^")="Y"),('$$CSUD) S I=1 Q ;CS ONLY
. S PSJX=0
. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIV,"CL","B",PSJCLI,0))
. I PSJSAR D
.. S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,"CL",PSJSAR,0)),"^",2)
.. S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
.. S PSJQ(PSJPD)=1_$S(PSJSAR]"":"^"_PSJSAR,1:""),(PSJQ,PSJX)=1
. Q:PSJX
. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIV,"PCG","C",PSJCLI,0))
. I PSJSAR D
.. S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,"PCG",PSJSAR,0)),"^",2)
.. S PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^") S:PSJSAR]"" PSJQ(PSJPD)="1^"_PSJSAR,(PSJQ,PSJX)=1
. Q:PSJX
. I $O(^PS(57.8,"AC",PSJCLI,0)) D
.. S PSJSAR=$O(^PS(57.8,"AC",PSJCLI,0))
.. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIV,"VCG","B",PSJSAR,0))
.. Q:'PSJSAR
.. S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,"VCG",PSJSAR,0)),"^",2)
.. S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
.. S PSJQ(PSJPD)="1"_$S(PSJSAR]"":"^"_PSJSAR,1:""),(PSJQ,PSJX)=1
. Q:PSJX
. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN","B",0)) I PSJSAR'="" D
.. N PSJWC,PSJLEN S PSJWC="" F S PSJWC=$O(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN","B",PSJWC)) Q:PSJWC="" D
... I $E(PSJCL,1,$L(PSJWC))=PSJWC S PSJLEN($L(PSJWC),PSJWC)=""
.. I $D(PSJLEN) D
... S PSJSAR=$O(PSJLEN(999),-1)
... S PSJSAR=$O(PSJLEN(PSJSAR,0))
... S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN","B",PSJSAR,0))
... S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN",PSJSAR,0)),"^",2)
... S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
... S PSJQ(PSJPD)="1"_$S(PSJSAR]"":"^"_PSJSAR,1:""),(PSJQ,PSJX)=1
. Q:PSJX
. I $P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,0)),"^",3)="Y" D
.. S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,0)),"^",4)
.. S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
.. S PSJQ(PSJPD)="1"_$S(PSJSAR]"":"^"_PSJSAR,1:""),PSJQ=1
Q PSJQ
;
CHKINPF ;
N VAIP D IN5^VADPT Q:'VAIP(5)
N PSJDIV S PSJDIV=+$P($G(^DIC(42,+VAIP(5),0)),"^",11)
Q:'PSJDIV
N PSJPD S PSJPD=0
F S PSJPD=$O(^PS(58.7,"AD",PSJDIV,PSJPD)) Q:'PSJPD D
. Q:'$D(PSJAP(PSJPD))
. I $P(^PS(58.7,PSJPD,0),"^",6)'="Y" K PSJAP(PSJPD) Q ;SEND CHECKIN/SURG HL7 FOR INPT
. N DN S DN=$G(^PS(58.7,PSJPD,"DIV",PSJDIV,0)) I DN="" K PSJAP(PSJPD) Q
. N DC S DC=$P(DN,"^",2)
. I DC&(DC<DT) K PSJAP(PSJPD) Q ;DIV INACTIVE
Q
;
SRCS ;Surgery case nightly task
N PSJAP,PSJPA S PSJAP=0,PSJPA=1 D EN1 I 'PSJAP W !!,"PADE not setup - Quitting..." 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))) W !!,"PADE HL7 Protocols are not setup - Quitting..." Q
K %DT
S %DT(0)=DT,%DT("B")="T",%DT("A")="Enter date of Surgery cases to send to PADE: "
S %DT="EPXA" D ^%DT Q:Y<0
N SDT,BDT,EDT
S SDT=Y K %DT
S BDT=SDT-.1,EDT=SDT+.9,BDT=$O(^SRF("AC",BDT))
I 'BDT!(BDT>EDT) W !,"No data to send for the given date - Quitting..." Q
K DIR S DIR("B")="NO",DIR(0)="Y",DIR("A")="Do you want to continue"
D ^DIR Q:Y<1
S ZTDTH="",ZTRTN="TASK^PSJPDCLA",ZTDESC="Surgery appt. sent to PADE",ZTIO=""
F XX="PSJAP(","SDT","EDT","SNM","CNM" S ZTSAVE(XX)=""
D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued !",! K ZTSK,ZTIO S:$D(ZTQUEUED) ZTREQ="@"
Q
;
TASK ;
I $G(PSJTASK) N PSJAP,PSJPA S PSJAP=0,PSJPA=1 D EN1 Q:'PSJAP N SNM,CNM D Q:'PSJAP
.S SNM="PSJ SIU-S12 SERVER",CNM="PSJ SIU-S12 CLIENT"
.S:'$O(^ORD(101,"B",SNM,0))!('$O(^ORD(101,"B",CNM,0))) PSJAP=0
N NHL D INIT^HLFNC2(SNM,.NHL) Q:$D(NHL)=1
N NFS,NECH,HL,BDT,DFN,PSJPD,PSJDIV,PSJDNM,PSJOR,PSJORN,PSJT,PSJQ,SEQ,PSJSAR,NSEG,PSJDTM,II,PSJNIP,PSJBAP,FTS
M HL=NHL,PSJBAP=PSJAP S (NFS,HLFS)=HL("FS"),NECH=$E(HL("ECH"),1)
I '$G(SDT) N SDT S SDT=DT
S BDT=SDT-.1,EDT=SDT+.9
F S BDT=$O(^SRF("AC",BDT)) Q:'BDT!(BDT>EDT) D
.S II=0 F S II=$O(^SRF("AC",BDT,II)) Q:'II D
..S DFN=+$G(^SRF(II,0)) Q:'DFN
..Q:$P($G(^SRF(II,30)),"^")]"" ;cancel node
..S PSJOR=+$P(^SRF(II,0),"^",2)
..Q:'PSJOR
..S PSJDTM=$P($G(^SRF(II,31)),"^",4) Q:'PSJDTM
..S PSJOR=$P($G(^SRS(PSJOR,0)),"^")
..Q:'PSJOR
..S PSJDIV=+$P($G(^SC(PSJOR,0)),"^",15)
..Q:'PSJDIV S PSJDNM=$P($$SITE^VASITE(,PSJDIV),"^",3) Q:PSJDNM=""
..S PSJORN=$P(^SC(PSJOR,0),"^"),PSJNIP=0,FTS=""
..K PSJT,PSJQ M PSJT=PSJAP
..S (SEQ,PSJPD)=0 K NSEG
..F S PSJPD=$O(^PS(58.7,"AD",PSJDIV,PSJPD)) Q:'PSJPD D
...Q:'$D(PSJT(PSJPD))
...I $P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,0)),"^",8)'="Y" K PSJT(PSJPD) Q
...I $P($G(^DPT(DFN,.1)),"^")]""&($P(^PS(58.7,PSJPD,0),"^",6)'="Y") K PSJT(PSJPD) Q
...S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIV,"OR","B",PSJOR,0))
...I 'PSJSAR K PSJT(PSJPD) Q
...S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIV,"OR",PSJSAR,0)),"^",2)
...S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
...S PSJQ(PSJPD)=1_$S(PSJSAR]"":"^"_PSJSAR,1:""),PSJQ=1
..Q:'$O(PSJQ(""))
..N PSJQS I $P($G(^DPT(DFN,.1)),"^")]"" D
...N PSJQ,PSJWD,PSJRBD
...D IN5^VADPT
...S PSJWD=$P(VAIP(5),"^",2),PSJRBD=$P(VAIP(6),"^",2)
...S PSJQ=$$CHKPD^PSJPDCL(PSJWD,PSJRBD)
...M PSJAP=PSJBAP
...I 'PSJQ S PSJNIP=1 Q
...M PSJQS=PSJQ
...S FTS=$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2)
..D SRBLD,SEND
Q
;
SRBLD ;
N SEG,VAFSTR,EVNTHL7,EVNTDATE,VAFPID,HLQ
S VAFSTR="1,5,7,8,19",HLQ=""
N VAFPID,M
S VAFPID=$$EN^VAFCPID(DFN,VAFSTR)
S SEQ=SEQ+1
S NSEG(SEQ)=$TR(VAFPID,"""""","")
S M=$O(VAFPID(0)) I M S NSEG(SEQ,M)=$TR(VAFPID(M),"""""","")
S VAFSTR=",2,3,10,18,21,39"
I $G(PSJNIP) S VAFSTR=",2,10,18,21,39"
S SEG=$$IN^VAFHLPV1(DFN,"",VAFSTR,"","",1,"")
S SEG=$TR(SEG,"""""","")
S:$P(SEG,HLFS,4)="" $P(SEG,HLFS,3)="O"
S $P(SEG,HLFS,12)=PSJORN,$P(SEG,HLFS,40)=PSJDNM
S:$G(PSJPV50) $P(SEG,HLFS,51)=PSJPV50
S SEQ=SEQ+1
S NSEG(SEQ)=SEG
D AGY^PSJPDCL
D SCH
Q
;
DIVCHK(DIV) ;
N PSJPD
F S PSJPD=$O(^PS(58.7,"AD",DIV,PSJPD)) Q:'PSJPD D
. Q:'$D(PSJAP(PSJPD))
Q
;
CSIV() ;
N J,SCH,DIN,QQ S (J,SCH,QQ)=0 F S J=$O(^PS(55,DFN,"IV",+RXO,"AD",J)) Q:'J!(QQ) D
. S DIN=$P($G(^PS(55,DFN,"IV",+RXO,"AD",J,0)),"^")
. S DIN=$P($G(^PS(52.6,DIN,0)),"^",2) Q:DIN=""
. S SCH=$P($G(^PSDRUG(DIN,0)),"^",3)
. I SCH["2"!(SCH["3")!(SCH["4")!(SCH["5") S QQ=1
Q:QQ 1
S J=0 F S J=$O(^PS(55,DFN,"IV",+RXO,"SOL",J)) Q:'J!(QQ) D Q:QQ
. S DIN=$P($G(^PS(55,DFN,"IV",+RXO,"SOL",J,0)),"^")
. S DIN=$P($G(^PS(52.7,J,0)),"^",2) Q:DIN=""
. S SCH=$P(^PSDRUG(DIN,0),"^",3)
. I SCH["2"!(SCH["3")!(SCH["4")!(SCH["5") S QQ=1
Q QQ
;
CSUD() ;
N J,SCH,QQ S (J,QQ,SCH)=0 F S J=$O(^PS(55,DFN,5,+RXO,1,"B",J)) Q:'J!(QQ) D Q:QQ
. S SCH=$P($G(^PSDRUG(J,0)),"^",3)
. I SCH["2"!(SCH["3")!(SCH["4")!(SCH["5") S QQ=1
Q QQ
;
AIL ;
S SEG="AIL"
S $P(SEG,HLFS,2)=1
S $P(SEG,HLFS,3)=PSJDIV_NECH_NECH_NECH_PSJDNM
S $P(SEG,HLFS,4)=PSJOR_NECH_PSJORN
S SEQ=SEQ+1
S NSEG(SEQ)=SEG
Q
;
SCH ;
S SEG="SCH"
S $P(SEG,HLFS,2)=DFN_":"_PSJOR_":"_$$FMTHL7^XLFDT(PSJDTM)
S $P(SEG,HLFS,5)="S12"
S $P(SEG,HLFS,12)=NECH_NECH_NECH_$$FMTHL7^XLFDT(PSJDTM)
S SEQ=SEQ+1,PDL(16)=PSJDTM
S NSEG(SEQ)=SEG
Q
;
PIVOT(DFN,PSJON,PSWARDH,PSRBDH,PSFTSH) ; Get pivot # for patient=DFN and order=PSJON
Q:'$G(DFN) ""
Q:'$G(PSJON) ""
N PSJOTYP,PSJOLIDT,PSJPIVOT,ADMDT,VAIP
S PSWARDH="",PSRBDH=""
S PSJOTYP=$E(PSJON,$L(PSJON))
I PSJOTYP="U" S PSJOLIDT=$P($G(^PS(55,+DFN,5,+PSJON,0)),"^",16)
I PSJOTYP="V" S PSJOLIDT=+$G(^PS(55,+DFN,"IV",+PSJON,2))
Q:'$G(PSJOLIDT) "" ; No log-in date; bad order #
S VAIP("D")=PSJOLIDT D IN5^VADPT ; Get admission info related to order's login date
S ADMDT=+VAIP(13,1)
S PSWARDH=$P($G(VAIP(5)),"^",2)
S PSRBDH=$P($G(VAIP(6)),"^",2)
S PSFTSH=$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2)
S PSJPIVOT=+$$PIVCHK^VAFHPIVT(DFN,ADMDT,1,VAIP(13)_";DGPM(")
Q PSJPIVOT
;
LOGPIVOT(DFN,PSJON) ; Get pivot for Patient DFN, order PSJON, from log file
Q:'$G(DFN)
Q:'$G(PSJON)
N PSJPIVOT,PSJLOGEN,II,PSJLOGND,PSJORACT,PSJLOGOR,PSPIVTMP
S PSJPIVOT=""
S II=0 F S II=$O(^PS(58.72,"C",DFN,II)) Q:'II!$G(PSPIVTMP) D
.S PSJLOGND=$G(^PS(58.72,II,0))
.S PSJORACT=$P(PSJLOGND,"^",16) Q:PSJORACT'="NW"
.S PSJLOGOR=$P(PSJLOGND,"^",3) Q:PSJLOGOR'=PSJON
.S PSPIVTMP=$P(PSJLOGND,"^",7)
I $G(PSPIVTMP) S PSJPIVOT=PSPIVTMP
I '$G(PSPIVTMP) S PSJPIVOT=-1
Q PSJPIVOT
;
RESNDORDS(DFN,PSJOR,PSJDIV,PDSYS,FILTER) ; Resend all orders for the input CLINIC's SEND AREA
;INPUT:
; DFN: Patient Identifier from PATIENT file #2
; PSJOR: Clinic IEN from HOSPITAL LOCATION file #44
; PSJORN: Clinic NAME from HOSPITAL LOCATION file #44
; PSJDIV: PADE Division
; PDSYS: PADE System from file #58.7
;
N PCLSAS,SENDAREA,RESNDCL,PSJSYDIV,PTSNDLOG
;
; Re-send orders for checked-in clinic
S PCLSAS=$$GETSAR^PSJPDAPP(PDSYS,PSJDIV,PSJOR,FILTER)
I $L(PCLSAS) D
. D GETPTO^PSJPADE(DFN,PSJOR)
. S ^TMP($J,"PSJCLSA",PDSYS,"DFN",DFN,"CL",PSJOR)=1 ; Orders sent for this patient/clinic, don't send again
;
; Get SEND AREA for checked-in clinic
S PCLSAS=$$GETSAR^PSJPDAPP(PDSYS,PSJDIV,PSJOR,0)
S SENDAREA=$P(PCLSAS,"^",6)
Q:'SENDAREA
;
; Send orders in SEND AREA of checked-in clinic
S PSJSYDIV=0 F S PSJSYDIV=$O(^TMP($J,"PSJCLSA",PDSYS,PSJSYDIV)) Q:'PSJSYDIV D
. S RESNDCL=0 F S RESNDCL=$O(^TMP($J,"PSJCLSA",PDSYS,PSJSYDIV,"SA",SENDAREA,RESNDCL)) Q:'RESNDCL D
.. Q:$G(^TMP($J,"PSJCLSA",PDSYS,"DFN",DFN,"CL",RESNDCL)) ; Don't send orders for patient/clinic if already sent
.. D GETPTO^PSJPADE(DFN,RESNDCL)
.. S ^TMP($J,"PSJCLSA",PDSYS,"DFN",DFN,"CL",RESNDCL)=1 ; Orders sent for this patient/clinic, don't send again
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDCLA 14934 printed Sep 23, 2025@19:44:50 Page 2
PSJPDCLA ;BIR/MA/MC - PADE HL7 - CLINIC CHECK ;07/08/15
+1 ;;5.0;INPATIENT MEDICATIONS;**317,337,362,432**;16 DEC 97;Build 18
+2 ;Reference to EN^VAFCPID supported by DBIA 3015
+3 ;Reference to IN^VAFHLPV1 supported by DBIA 3018
+4 ;Reference to $$PIVCHK^VAFHPIVT supported by DBIA 6606
+5 ;Reference to ^PS(55 is supported by DBIA 2191
+6 ;Reference to ^PS(52.6 supported by DBIA 1231
+7 ;Reference to ^PS(52.7 supported by DBIA 2173
+8 ;Reference to ^DIC(42 supported by DBIA 10039
+9 ;Reference to ^ORD(101 supported by DBIA 872
+10 ;Reference to ^SC supported by DBIA 10040
+11 ;Reference to ^DPT supported by DBIA 10035
+12 ;Reference to ^PSDRUG supported by DBIA 2192
+13 ;Reference to ^SRF supported by DBIA 103
+14 ;Reference to ^SRS supported by DBIA 3362
+15 QUIT
+16 ;
EN ; Get SDAM Message and send to PADE.
+1 if $GET(SDAMEVT)'=4!($PIECE($GET(SDATA),"^",4)<1)
QUIT
+2 NEW PSJAP
SET PSJAP=0
EN1 ;
+1 if '$PIECE($$SEND^VAFHUTL(),"^",2)
QUIT
+2 if $ORDER(^PS(58.7,"B",""))=""
QUIT
+3 NEW I,J
SET I=0
+4 FOR
SET I=$ORDER(^PS(58.7,I))
if 'I
QUIT
SET J=$$PDACT(I)
+5 if 'PSJAP
QUIT
+6 if $GET(PSJPA)
QUIT
+7 if '$GET(HLEID)
QUIT
+8 IF $GET(HL("ETN"))=""
DO INIT^HLFNC2(HLEID,.HL)
if $DATA(HL)=1
QUIT
+9 NEW FS,ECH
SET FS=HL("FS")
SET ECH=$EXTRACT(HL("ECH"),1)
+10 NEW SNM,CNM
SET SNM="PSJ SIU-S12 SERVER"
SET CNM="PSJ SIU-S12 CLIENT"
+11 if '$ORDER(^ORD(101,"B",SNM,0))
QUIT
+12 if '$ORDER(^ORD(101,"B",CNM,0))
QUIT
+13 DO INIT^HLFNC2(SNM,.NHL)
if $DATA(NHL)=1
QUIT
+14 NEW NFS,NECH,HLFS,HLECH,Y
SET (HLFS,NFS)=NHL("FS")
SET NECH=$EXTRACT(NHL("ECH"),1)
+15 NEW PSJX,PSJQ,NSEG,SEQ,PSJORN,PSJOR,PSJDTM,PSJDIV,PSJDNM,PSJPV50,PDL
+16 SET (PSJQ,SEQ)=0
SET PSJX=1
SET (PSJPV50,PSJORN)=""
+17 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0!(PSJORN]"")
QUIT
Begin DoDot:1
+18 IF $EXTRACT(HLNODE,1,3)="PV1"
SET PSJORN=$PIECE(HLNODE,FS,4)
SET PSJPV50=$PIECE(HLNODE,FS,51)
End DoDot:1
+19 if PSJORN=""
QUIT
+20 DO CHKINPF
+21 if '$ORDER(PSJAP(0))
QUIT
+22 NEW PSJBAP,FTS
MERGE PSJBAP=PSJAP
+23 KILL NSEG
NEW PSJQW,PSJNIP
SET PSJNIP=0
SET FTS=""
+24 IF $PIECE($GET(^DPT(DFN,.1)),"^")]""
Begin DoDot:1
+25 DO IN5^VADPT
+26 NEW PSJQ,PSJWD,PSJRBD
+27 SET PSJWD=$PIECE(VAIP(5),"^",2)
SET PSJRBD=$PIECE(VAIP(6),"^",2)
+28 SET PSJQ=$$CHKPD^PSJPDCL(PSJWD,PSJRBD)
+29 IF 'PSJQ
SET PSJNIP=1
QUIT
+30 MERGE PSJQW=PSJQ
+31 SET FTS=$PIECE(VAIP(8),"^")_NECH_$PIECE(VAIP(8),"^",2)
End DoDot:1
+32 MERGE PSJAP=PSJBAP
+33 KILL PSJQ
SET PSJQ=$$CHKPDCL(PSJORN)
+34 if 'PSJQ
QUIT
+35 SET PSJDTM=$GET(HLP("DT"))
+36 SET PSJOR=$ORDER(^SC("B",PSJORN,0))
+37 SET PSJDIV=+$PIECE($GET(^SC(PSJOR,0)),"^",15)
+38 SET PSJDNM=$PIECE($$SITE^VASITE(,PSJDIV),"^",3)
+39 SET ZTIO=""
+40 SET ZTRTN="CLCI^PSJPDCLA"
+41 FOR XX="PSJPV50","PSJQ(","PSJOR","PSJORN","PSJDTM","PSJDIV","PSJDNM","DFN","PSJQW(","NHL(","SNM","CNM","FTS"
SET ZTSAVE(XX)=""
+42 SET ZTDESC="Send PADE HL7 Checkin Message"
+43 SET ZTDTH=$HOROLOG
+44 DO ^%ZTLOAD
+45 QUIT
+46 ;
CLCI ;
+1 NEW XX,ZZ1
SET XX=0
FOR
SET XX=$ORDER(PSJQ(XX))
if 'XX
QUIT
Begin DoDot:1
+2 SET PSJND=$GET(^PS(58.7,XX,0))
+3 SET PSJVNM=$PIECE(PSJND,"^")
SET PSJDNS=$PIECE(PSJND,"^",2)
SET PSJVP=$PIECE(PSJND,"^",3)
+4 SET ZZ1=""
SET PSJNIP=0
+5 ;I 'PSJNIP,$P(PSJND,"^",6)'="Y" Q
+6 ;*362 - if inpatient and the flag SEND CHECKIN/SURG HL7 FOR INPT is not "Y" then quit
IF $PIECE($GET(^DPT(DFN,.1)),"^")]""
IF $PIECE(PSJND,"^",6)'="Y"
QUIT
+7 IF $DATA(PSJQW(XX))
IF $PIECE(PSJQW(XX),"^",2)'=""
SET ZZ1=$PIECE(PSJQW(XX),"^",2)
+8 IF '$DATA(PSJQW(XX))
SET PSJNIP=1
+9 SET (HLFS,NFS)=NHL("FS")
SET NECH=$EXTRACT(NHL("ECH"),1)
SET HLECH=NHL("ECH")
+10 KILL NSEG
SET SEQ=0
NEW HL
MERGE HL=NHL
DO SRBLD
NEW ZZ2
SET ZZ2=$SELECT($PIECE(PSJQ(XX),"^",2)'="":$PIECE(PSJQ(XX),"^",2),1:"")
+11 SET SEQ=SEQ+1
SET NSEG(SEQ)="ZZZ"_HL("FS")_$SELECT(ZZ1'="":ZZ1,1:"")_HL("FS")_ZZ2_HL("FS")_FTS
+12 KILL HLP,HLA
SET HLP=""
SET HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
+13 DO PV19^PSJPDAPP
MERGE HLA("HLS")=NSEG
+14 DO GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
+15 DO LOG^PSJPADE
+16 ;check for O11 re-send
+17 ; Build PADE clinics/send areas per parameter info
DO GETPSARS^PSJPDAPP(XX,DFN,3)
+18 ; Resend all orders for the input CLINIC's SEND AREA
DO RESNDORDS^PSJPDCLA(DFN,PSJOR,PSJDIV,XX,2)
End DoDot:1
+19 DO KILLTMP^PSJPDAPP
+20 QUIT
+21 ;
SEND ;
+1 NEW XX,PSJND,PSJVNM,PSJDNS,PSJVP,VR,HLA,CT
+2 MERGE HLA("HLS")=NSEG
+3 DO INIT^HLFNC2(SNM,.HL)
if $DATA(HL)=1
QUIT
+4 SET XX=0
SET CT=$ORDER(NSEG(9999),-1)+1
+5 ;sends HL7 message for each PADE SERVER
FOR
SET XX=$ORDER(PSJQ(XX))
if 'XX
QUIT
Begin DoDot:1
+6 SET PSJND=$GET(^PS(58.7,XX,0))
+7 if PSJND=""
QUIT
+8 SET PSJVNM=$PIECE(PSJND,"^")
SET PSJDNS=$PIECE(PSJND,"^",2)
SET PSJVP=$PIECE(PSJND,"^",3)
+9 if PSJVNM=""!(PSJDNS="")!('PSJVP)
QUIT
+10 NEW HLP,PSJSND
SET HLP=""
+11 SET HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
+12 IF '$DATA(HL)
MERGE HL=NHL
+13 NEW ZZ2,ZZ1
SET ZZ2=$PIECE(PSJQ(XX),"^",2)
+14 SET ZZ1=$SELECT($PIECE($GET(PSJQS(XX)),"^",2)]"":$PIECE($GET(PSJQS(XX)),"^",2),1:"")
+15 SET NSEG(CT)="ZZZ"_HL("FS")_ZZ1_HL("FS")_ZZ2_HL("FS")_FTS
+16 DO PV19^PSJPDAPP
+17 KILL HLA
MERGE HLA("HLS")=NSEG
+18 DO GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
+19 DO LOG^PSJPADE
End DoDot:1
+20 QUIT
+21 ;
TR(SEG) ; Translate the VAFC message delimiters to HL7 delimiters for PADE
+1 NEW CSEG
+2 SET CSEG=$TRANSLATE(SEG,HL("FS")_HL("ECH"),NHL("FS")_NHL("ECH"))
+3 SET CSEG=$TRANSLATE(CSEG,"""","")
+4 QUIT CSEG
+5 ;
PDACT(PSJPD) ;
+1 if '$DATA(^PS(58.7,PSJPD,0))
QUIT 0
+2 NEW PSJVNM,PSJDNS,PSJVP,PSJACT,PSJND
SET PSJND=$GET(^PS(58.7,PSJPD,0))
+3 SET PSJVNM=$PIECE(PSJND,"^")
SET PSJDNS=$PIECE(PSJND,"^",2)
SET PSJVP=$PIECE(PSJND,"^",3)
+4 IF PSJVNM=""!(PSJDNS="")!('PSJVP)
QUIT 0
+5 SET PSJACT=$PIECE(PSJND,"^",4)
+6 IF PSJACT&(PSJACT<DT)
QUIT 0
+7 SET PSJAP(PSJPD)=""
SET PSJAP=1
+8 QUIT 1
+9 ;
CHKPDCL(PSJCL) ;
+1 NEW PSJCLI
SET PSJCLI=$SELECT($GET(PSJPDO):PSJCL,1:$ORDER(^SC("B",PSJCL,"")))
+2 if 'PSJCLI
QUIT 0
+3 NEW PSJDIV
SET PSJDIV=+$PIECE($GET(^SC(PSJCLI,0)),"^",15)
+4 if 'PSJDIV
QUIT 0
+5 SET PSJCL=$PIECE(^SC(PSJCLI,0),"^")
+6 NEW PSJPD,PSJSAR
SET (PSJQ,PSJPD)=0
+7 FOR
SET PSJPD=$ORDER(^PS(58.7,"AD",PSJDIV,PSJPD))
if 'PSJPD
QUIT
Begin DoDot:1
+8 if '$DATA(PSJAP(PSJPD))
QUIT
+9 NEW DN
SET DN=$GET(^PS(58.7,PSJPD,"DIV",PSJDIV,0))
if DN=""
QUIT
+10 NEW DC
SET DC=$PIECE(DN,"^",2)
+11 ;DIV INACTIVE
IF DC&(DC<DT)
QUIT
+12 IF $GET(PSJPDO)=1
NEW I
SET I=0
Begin DoDot:2
+13 ;DON'T SEND ORDER MESSAGES
IF $PIECE($GET(^(2)),"^")'="Y"
SET I=1
QUIT
+14 ;DON'T SEND CLINIC IV
IF $GET(RXO)["V"
IF $PIECE(DN,"^",7)'="Y"
SET I=1
QUIT
+15 ;CS ONLY
IF $GET(RXO)["V"
IF ($PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,3)),"^")="Y")
IF ('$$CSIV)
SET I=1
QUIT
+16 ;CS ONLY
IF $GET(RXO)["U"
IF ($PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,3)),"^")="Y")
IF ('$$CSUD)
SET I=1
QUIT
End DoDot:2
if I
QUIT
+17 SET PSJX=0
+18 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIV,"CL","B",PSJCLI,0))
+19 IF PSJSAR
Begin DoDot:2
+20 SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,"CL",PSJSAR,0)),"^",2)
+21 if PSJSAR
SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
+22 SET PSJQ(PSJPD)=1_$SELECT(PSJSAR]"":"^"_PSJSAR,1:"")
SET (PSJQ,PSJX)=1
End DoDot:2
+23 if PSJX
QUIT
+24 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIV,"PCG","C",PSJCLI,0))
+25 IF PSJSAR
Begin DoDot:2
+26 SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,"PCG",PSJSAR,0)),"^",2)
+27 SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
if PSJSAR]""
SET PSJQ(PSJPD)="1^"_PSJSAR
SET (PSJQ,PSJX)=1
End DoDot:2
+28 if PSJX
QUIT
+29 IF $ORDER(^PS(57.8,"AC",PSJCLI,0))
Begin DoDot:2
+30 SET PSJSAR=$ORDER(^PS(57.8,"AC",PSJCLI,0))
+31 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIV,"VCG","B",PSJSAR,0))
+32 if 'PSJSAR
QUIT
+33 SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,"VCG",PSJSAR,0)),"^",2)
+34 if PSJSAR
SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
+35 SET PSJQ(PSJPD)="1"_$SELECT(PSJSAR]"":"^"_PSJSAR,1:"")
SET (PSJQ,PSJX)=1
End DoDot:2
+36 if PSJX
QUIT
+37 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN","B",0))
IF PSJSAR'=""
Begin DoDot:2
+38 NEW PSJWC,PSJLEN
SET PSJWC=""
FOR
SET PSJWC=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN","B",PSJWC))
if PSJWC=""
QUIT
Begin DoDot:3
+39 IF $EXTRACT(PSJCL,1,$LENGTH(PSJWC))=PSJWC
SET PSJLEN($LENGTH(PSJWC),PSJWC)=""
End DoDot:3
+40 IF $DATA(PSJLEN)
Begin DoDot:3
+41 SET PSJSAR=$ORDER(PSJLEN(999),-1)
+42 SET PSJSAR=$ORDER(PSJLEN(PSJSAR,0))
+43 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN","B",PSJSAR,0))
+44 SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,"WCN",PSJSAR,0)),"^",2)
+45 if PSJSAR
SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
+46 SET PSJQ(PSJPD)="1"_$SELECT(PSJSAR]"":"^"_PSJSAR,1:"")
SET (PSJQ,PSJX)=1
End DoDot:3
End DoDot:2
+47 if PSJX
QUIT
+48 IF $PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,0)),"^",3)="Y"
Begin DoDot:2
+49 SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,0)),"^",4)
+50 if PSJSAR
SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
+51 SET PSJQ(PSJPD)="1"_$SELECT(PSJSAR]"":"^"_PSJSAR,1:"")
SET PSJQ=1
End DoDot:2
End DoDot:1
+52 QUIT PSJQ
+53 ;
CHKINPF ;
+1 NEW VAIP
DO IN5^VADPT
if 'VAIP(5)
QUIT
+2 NEW PSJDIV
SET PSJDIV=+$PIECE($GET(^DIC(42,+VAIP(5),0)),"^",11)
+3 if 'PSJDIV
QUIT
+4 NEW PSJPD
SET PSJPD=0
+5 FOR
SET PSJPD=$ORDER(^PS(58.7,"AD",PSJDIV,PSJPD))
if 'PSJPD
QUIT
Begin DoDot:1
+6 if '$DATA(PSJAP(PSJPD))
QUIT
+7 ;SEND CHECKIN/SURG HL7 FOR INPT
IF $PIECE(^PS(58.7,PSJPD,0),"^",6)'="Y"
KILL PSJAP(PSJPD)
QUIT
+8 NEW DN
SET DN=$GET(^PS(58.7,PSJPD,"DIV",PSJDIV,0))
IF DN=""
KILL PSJAP(PSJPD)
QUIT
+9 NEW DC
SET DC=$PIECE(DN,"^",2)
+10 ;DIV INACTIVE
IF DC&(DC<DT)
KILL PSJAP(PSJPD)
QUIT
End DoDot:1
+11 QUIT
+12 ;
SRCS ;Surgery case nightly task
+1 NEW PSJAP,PSJPA
SET PSJAP=0
SET PSJPA=1
DO EN1
IF 'PSJAP
WRITE !!,"PADE not setup - Quitting..."
QUIT
+2 NEW SNM,CNM
SET SNM="PSJ SIU-S12 SERVER"
SET CNM="PSJ SIU-S12 CLIENT"
+3 IF '$ORDER(^ORD(101,"B",SNM,0))!('$ORDER(^ORD(101,"B",CNM,0)))
WRITE !!,"PADE HL7 Protocols are not setup - Quitting..."
QUIT
+4 KILL %DT
+5 SET %DT(0)=DT
SET %DT("B")="T"
SET %DT("A")="Enter date of Surgery cases to send to PADE: "
+6 SET %DT="EPXA"
DO ^%DT
if Y<0
QUIT
+7 NEW SDT,BDT,EDT
+8 SET SDT=Y
KILL %DT
+9 SET BDT=SDT-.1
SET EDT=SDT+.9
SET BDT=$ORDER(^SRF("AC",BDT))
+10 IF 'BDT!(BDT>EDT)
WRITE !,"No data to send for the given date - Quitting..."
QUIT
+11 KILL DIR
SET DIR("B")="NO"
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
+12 DO ^DIR
if Y<1
QUIT
+13 SET ZTDTH=""
SET ZTRTN="TASK^PSJPDCLA"
SET ZTDESC="Surgery appt. sent to PADE"
SET ZTIO=""
+14 FOR XX="PSJAP(","SDT","EDT","SNM","CNM"
SET ZTSAVE(XX)=""
+15 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Task Queued !",!
KILL ZTSK,ZTIO
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+16 QUIT
+17 ;
TASK ;
+1 IF $GET(PSJTASK)
NEW PSJAP,PSJPA
SET PSJAP=0
SET PSJPA=1
DO EN1
if 'PSJAP
QUIT
NEW SNM,CNM
Begin DoDot:1
+2 SET SNM="PSJ SIU-S12 SERVER"
SET CNM="PSJ SIU-S12 CLIENT"
+3 if '$ORDER(^ORD(101,"B",SNM,0))!('$ORDER(^ORD(101,"B",CNM,0)))
SET PSJAP=0
End DoDot:1
if 'PSJAP
QUIT
+4 NEW NHL
DO INIT^HLFNC2(SNM,.NHL)
if $DATA(NHL)=1
QUIT
+5 NEW NFS,NECH,HL,BDT,DFN,PSJPD,PSJDIV,PSJDNM,PSJOR,PSJORN,PSJT,PSJQ,SEQ,PSJSAR,NSEG,PSJDTM,II,PSJNIP,PSJBAP,FTS
+6 MERGE HL=NHL,PSJBAP=PSJAP
SET (NFS,HLFS)=HL("FS")
SET NECH=$EXTRACT(HL("ECH"),1)
+7 IF '$GET(SDT)
NEW SDT
SET SDT=DT
+8 SET BDT=SDT-.1
SET EDT=SDT+.9
+9 FOR
SET BDT=$ORDER(^SRF("AC",BDT))
if 'BDT!(BDT>EDT)
QUIT
Begin DoDot:1
+10 SET II=0
FOR
SET II=$ORDER(^SRF("AC",BDT,II))
if 'II
QUIT
Begin DoDot:2
+11 SET DFN=+$GET(^SRF(II,0))
if 'DFN
QUIT
+12 ;cancel node
if $PIECE($GET(^SRF(II,30)),"^")]""
QUIT
+13 SET PSJOR=+$PIECE(^SRF(II,0),"^",2)
+14 if 'PSJOR
QUIT
+15 SET PSJDTM=$PIECE($GET(^SRF(II,31)),"^",4)
if 'PSJDTM
QUIT
+16 SET PSJOR=$PIECE($GET(^SRS(PSJOR,0)),"^")
+17 if 'PSJOR
QUIT
+18 SET PSJDIV=+$PIECE($GET(^SC(PSJOR,0)),"^",15)
+19 if 'PSJDIV
QUIT
SET PSJDNM=$PIECE($$SITE^VASITE(,PSJDIV),"^",3)
if PSJDNM=""
QUIT
+20 SET PSJORN=$PIECE(^SC(PSJOR,0),"^")
SET PSJNIP=0
SET FTS=""
+21 KILL PSJT,PSJQ
MERGE PSJT=PSJAP
+22 SET (SEQ,PSJPD)=0
KILL NSEG
+23 FOR
SET PSJPD=$ORDER(^PS(58.7,"AD",PSJDIV,PSJPD))
if 'PSJPD
QUIT
Begin DoDot:3
+24 if '$DATA(PSJT(PSJPD))
QUIT
+25 IF $PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,0)),"^",8)'="Y"
KILL PSJT(PSJPD)
QUIT
+26 IF $PIECE($GET(^DPT(DFN,.1)),"^")]""&($PIECE(^PS(58.7,PSJPD,0),"^",6)'="Y")
KILL PSJT(PSJPD)
QUIT
+27 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIV,"OR","B",PSJOR,0))
+28 IF 'PSJSAR
KILL PSJT(PSJPD)
QUIT
+29 SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIV,"OR",PSJSAR,0)),"^",2)
+30 if PSJSAR
SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
+31 SET PSJQ(PSJPD)=1_$SELECT(PSJSAR]"":"^"_PSJSAR,1:"")
SET PSJQ=1
End DoDot:3
+32 if '$ORDER(PSJQ(""))
QUIT
+33 NEW PSJQS
IF $PIECE($GET(^DPT(DFN,.1)),"^")]""
Begin DoDot:3
+34 NEW PSJQ,PSJWD,PSJRBD
+35 DO IN5^VADPT
+36 SET PSJWD=$PIECE(VAIP(5),"^",2)
SET PSJRBD=$PIECE(VAIP(6),"^",2)
+37 SET PSJQ=$$CHKPD^PSJPDCL(PSJWD,PSJRBD)
+38 MERGE PSJAP=PSJBAP
+39 IF 'PSJQ
SET PSJNIP=1
QUIT
+40 MERGE PSJQS=PSJQ
+41 SET FTS=$PIECE(VAIP(8),"^")_NECH_$PIECE(VAIP(8),"^",2)
End DoDot:3
+42 DO SRBLD
DO SEND
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
SRBLD ;
+1 NEW SEG,VAFSTR,EVNTHL7,EVNTDATE,VAFPID,HLQ
+2 SET VAFSTR="1,5,7,8,19"
SET HLQ=""
+3 NEW VAFPID,M
+4 SET VAFPID=$$EN^VAFCPID(DFN,VAFSTR)
+5 SET SEQ=SEQ+1
+6 SET NSEG(SEQ)=$TRANSLATE(VAFPID,"""""","")
+7 SET M=$ORDER(VAFPID(0))
IF M
SET NSEG(SEQ,M)=$TRANSLATE(VAFPID(M),"""""","")
+8 SET VAFSTR=",2,3,10,18,21,39"
+9 IF $GET(PSJNIP)
SET VAFSTR=",2,10,18,21,39"
+10 SET SEG=$$IN^VAFHLPV1(DFN,"",VAFSTR,"","",1,"")
+11 SET SEG=$TRANSLATE(SEG,"""""","")
+12 if $PIECE(SEG,HLFS,4)=""
SET $PIECE(SEG,HLFS,3)="O"
+13 SET $PIECE(SEG,HLFS,12)=PSJORN
SET $PIECE(SEG,HLFS,40)=PSJDNM
+14 if $GET(PSJPV50)
SET $PIECE(SEG,HLFS,51)=PSJPV50
+15 SET SEQ=SEQ+1
+16 SET NSEG(SEQ)=SEG
+17 DO AGY^PSJPDCL
+18 DO SCH
+19 QUIT
+20 ;
DIVCHK(DIV) ;
+1 NEW PSJPD
+2 FOR
SET PSJPD=$ORDER(^PS(58.7,"AD",DIV,PSJPD))
if 'PSJPD
QUIT
Begin DoDot:1
+3 if '$DATA(PSJAP(PSJPD))
QUIT
End DoDot:1
+4 QUIT
+5 ;
CSIV() ;
+1 NEW J,SCH,DIN,QQ
SET (J,SCH,QQ)=0
FOR
SET J=$ORDER(^PS(55,DFN,"IV",+RXO,"AD",J))
if 'J!(QQ)
QUIT
Begin DoDot:1
+2 SET DIN=$PIECE($GET(^PS(55,DFN,"IV",+RXO,"AD",J,0)),"^")
+3 SET DIN=$PIECE($GET(^PS(52.6,DIN,0)),"^",2)
if DIN=""
QUIT
+4 SET SCH=$PIECE($GET(^PSDRUG(DIN,0)),"^",3)
+5 IF SCH["2"!(SCH["3")!(SCH["4")!(SCH["5")
SET QQ=1
End DoDot:1
+6 if QQ
QUIT 1
+7 SET J=0
FOR
SET J=$ORDER(^PS(55,DFN,"IV",+RXO,"SOL",J))
if 'J!(QQ)
QUIT
Begin DoDot:1
+8 SET DIN=$PIECE($GET(^PS(55,DFN,"IV",+RXO,"SOL",J,0)),"^")
+9 SET DIN=$PIECE($GET(^PS(52.7,J,0)),"^",2)
if DIN=""
QUIT
+10 SET SCH=$PIECE(^PSDRUG(DIN,0),"^",3)
+11 IF SCH["2"!(SCH["3")!(SCH["4")!(SCH["5")
SET QQ=1
End DoDot:1
if QQ
QUIT
+12 QUIT QQ
+13 ;
CSUD() ;
+1 NEW J,SCH,QQ
SET (J,QQ,SCH)=0
FOR
SET J=$ORDER(^PS(55,DFN,5,+RXO,1,"B",J))
if 'J!(QQ)
QUIT
Begin DoDot:1
+2 SET SCH=$PIECE($GET(^PSDRUG(J,0)),"^",3)
+3 IF SCH["2"!(SCH["3")!(SCH["4")!(SCH["5")
SET QQ=1
End DoDot:1
if QQ
QUIT
+4 QUIT QQ
+5 ;
AIL ;
+1 SET SEG="AIL"
+2 SET $PIECE(SEG,HLFS,2)=1
+3 SET $PIECE(SEG,HLFS,3)=PSJDIV_NECH_NECH_NECH_PSJDNM
+4 SET $PIECE(SEG,HLFS,4)=PSJOR_NECH_PSJORN
+5 SET SEQ=SEQ+1
+6 SET NSEG(SEQ)=SEG
+7 QUIT
+8 ;
SCH ;
+1 SET SEG="SCH"
+2 SET $PIECE(SEG,HLFS,2)=DFN_":"_PSJOR_":"_$$FMTHL7^XLFDT(PSJDTM)
+3 SET $PIECE(SEG,HLFS,5)="S12"
+4 SET $PIECE(SEG,HLFS,12)=NECH_NECH_NECH_$$FMTHL7^XLFDT(PSJDTM)
+5 SET SEQ=SEQ+1
SET PDL(16)=PSJDTM
+6 SET NSEG(SEQ)=SEG
+7 QUIT
+8 ;
PIVOT(DFN,PSJON,PSWARDH,PSRBDH,PSFTSH) ; Get pivot # for patient=DFN and order=PSJON
+1 if '$GET(DFN)
QUIT ""
+2 if '$GET(PSJON)
QUIT ""
+3 NEW PSJOTYP,PSJOLIDT,PSJPIVOT,ADMDT,VAIP
+4 SET PSWARDH=""
SET PSRBDH=""
+5 SET PSJOTYP=$EXTRACT(PSJON,$LENGTH(PSJON))
+6 IF PSJOTYP="U"
SET PSJOLIDT=$PIECE($GET(^PS(55,+DFN,5,+PSJON,0)),"^",16)
+7 IF PSJOTYP="V"
SET PSJOLIDT=+$GET(^PS(55,+DFN,"IV",+PSJON,2))
+8 ; No log-in date; bad order #
if '$GET(PSJOLIDT)
QUIT ""
+9 ; Get admission info related to order's login date
SET VAIP("D")=PSJOLIDT
DO IN5^VADPT
+10 SET ADMDT=+VAIP(13,1)
+11 SET PSWARDH=$PIECE($GET(VAIP(5)),"^",2)
+12 SET PSRBDH=$PIECE($GET(VAIP(6)),"^",2)
+13 SET PSFTSH=$PIECE(VAIP(8),"^")_NECH_$PIECE(VAIP(8),"^",2)
+14 SET PSJPIVOT=+$$PIVCHK^VAFHPIVT(DFN,ADMDT,1,VAIP(13)_";DGPM(")
+15 QUIT PSJPIVOT
+16 ;
LOGPIVOT(DFN,PSJON) ; Get pivot for Patient DFN, order PSJON, from log file
+1 if '$GET(DFN)
QUIT
+2 if '$GET(PSJON)
QUIT
+3 NEW PSJPIVOT,PSJLOGEN,II,PSJLOGND,PSJORACT,PSJLOGOR,PSPIVTMP
+4 SET PSJPIVOT=""
+5 SET II=0
FOR
SET II=$ORDER(^PS(58.72,"C",DFN,II))
if 'II!$GET(PSPIVTMP)
QUIT
Begin DoDot:1
+6 SET PSJLOGND=$GET(^PS(58.72,II,0))
+7 SET PSJORACT=$PIECE(PSJLOGND,"^",16)
if PSJORACT'="NW"
QUIT
+8 SET PSJLOGOR=$PIECE(PSJLOGND,"^",3)
if PSJLOGOR'=PSJON
QUIT
+9 SET PSPIVTMP=$PIECE(PSJLOGND,"^",7)
End DoDot:1
+10 IF $GET(PSPIVTMP)
SET PSJPIVOT=PSPIVTMP
+11 IF '$GET(PSPIVTMP)
SET PSJPIVOT=-1
+12 QUIT PSJPIVOT
+13 ;
RESNDORDS(DFN,PSJOR,PSJDIV,PDSYS,FILTER) ; Resend all orders for the input CLINIC's SEND AREA
+1 ;INPUT:
+2 ; DFN: Patient Identifier from PATIENT file #2
+3 ; PSJOR: Clinic IEN from HOSPITAL LOCATION file #44
+4 ; PSJORN: Clinic NAME from HOSPITAL LOCATION file #44
+5 ; PSJDIV: PADE Division
+6 ; PDSYS: PADE System from file #58.7
+7 ;
+8 NEW PCLSAS,SENDAREA,RESNDCL,PSJSYDIV,PTSNDLOG
+9 ;
+10 ; Re-send orders for checked-in clinic
+11 SET PCLSAS=$$GETSAR^PSJPDAPP(PDSYS,PSJDIV,PSJOR,FILTER)
+12 IF $LENGTH(PCLSAS)
Begin DoDot:1
+13 DO GETPTO^PSJPADE(DFN,PSJOR)
+14 ; Orders sent for this patient/clinic, don't send again
SET ^TMP($JOB,"PSJCLSA",PDSYS,"DFN",DFN,"CL",PSJOR)=1
End DoDot:1
+15 ;
+16 ; Get SEND AREA for checked-in clinic
+17 SET PCLSAS=$$GETSAR^PSJPDAPP(PDSYS,PSJDIV,PSJOR,0)
+18 SET SENDAREA=$PIECE(PCLSAS,"^",6)
+19 if 'SENDAREA
QUIT
+20 ;
+21 ; Send orders in SEND AREA of checked-in clinic
+22 SET PSJSYDIV=0
FOR
SET PSJSYDIV=$ORDER(^TMP($JOB,"PSJCLSA",PDSYS,PSJSYDIV))
if 'PSJSYDIV
QUIT
Begin DoDot:1
+23 SET RESNDCL=0
FOR
SET RESNDCL=$ORDER(^TMP($JOB,"PSJCLSA",PDSYS,PSJSYDIV,"SA",SENDAREA,RESNDCL))
if 'RESNDCL
QUIT
Begin DoDot:2
+24 ; Don't send orders for patient/clinic if already sent
if $GET(^TMP($JOB,"PSJCLSA",PDSYS,"DFN",DFN,"CL",RESNDCL))
QUIT
+25 DO GETPTO^PSJPADE(DFN,RESNDCL)
+26 ; Orders sent for this patient/clinic, don't send again
SET ^TMP($JOB,"PSJCLSA",PDSYS,"DFN",DFN,"CL",RESNDCL)=1
End DoDot:2
End DoDot:1
+27 QUIT
