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