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

PSJPDCL.m

Go to the documentation of this file.
  1. PSJPDCL ;BIR/MHA - PADE HL7 ADT MESSAGE CLIENT TO VAFC ADT SERVER ;07/08/15
  1. ;;5.0;INPATIENT MEDICATIONS;**317,337,347,379,389**;16 DEC 97;Build 4
  1. ;Reference to ^SC supported by DBIA 10040
  1. ;Reference to ^DIC(42 supported by DBIA 10039
  1. ;Reference to ^ORD(101 supported by DBIA 872
  1. ;Reference to ^DG(405.4 supported by DBIA 1380
  1. ;Reference to ^GMRADPT supported by DBIA 10099
  1. ;Reference to ^GMRVUTL supported by DBIA 1120
  1. ;Reference to ^GMRAOR2 supported by DBIA 2422
  1. ;
  1. Q
  1. ;
  1. EN ; Get ADT Message and send to PADE.
  1. Q:$O(^PS(58.7,"B",""))=""
  1. Q:'$G(HLEID)
  1. N PSJAP
  1. S PSJAP=0
  1. N I,J S I=0
  1. F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
  1. Q:'PSJAP
  1. I $G(HL("ETN"))="" D INIT^HLFNC2(HLEID,.HL) Q:$D(HL)=1
  1. N FS,ECH S FS=HL("FS"),ECH=$E(HL("ECH"),1)
  1. N SNM,SID,NHL S SNM="PSJ ADT-"_HL("ETN")_" SERVER"
  1. S SID=$O(^ORD(101,"B",SNM,0))
  1. Q:'SID
  1. D INIT^HLFNC2(SID,.NHL) Q:$D(NHL)=1
  1. N NFS,NECH S NFS=NHL("FS"),NECH=$E(NHL("ECH"),1)
  1. N NSEG,PSJQ,PSJLOC,PSJWARD,PSJRBD,SEQ,PSJX,VAIP,X,FTS
  1. S VAIP("D")="L" D IN5^VADPT S PSJRBD=$P(VAIP(6),"^",2),FTS=$S($P(VAIP(8),"^")]"":$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2),1:"")
  1. S SEQ=0,PSJQ=0,PSJX=1 S:HL("ETN")="A11" FTS=""
  1. F I=1:1 X HLNEXT Q:HLQUIT'>0!('PSJX) D
  1. . Q:$E(HLNODE,1,3)="MSH"
  1. . Q:$E(HLNODE,1,3)="OBX"
  1. . Q:$E(HLNODE,1,3)="ROL"
  1. . Q:$E(HLNODE,1)="Z"
  1. . S SEQ=SEQ+1
  1. . S NSEG(SEQ)=$$TR(HLNODE)
  1. . S J=0 F S J=$O(HLNODE(J)) Q:'J S NSEG(SEQ,J)=$$TR(HLNODE(J))
  1. . I $E(HLNODE,1,3)="PV1" D
  1. .. S PSJLOC=$P(HLNODE,FS,4)
  1. .. S PSJWARD=$P(PSJLOC,ECH) Q:PSJWARD=""
  1. .. S PSJQ=$$CHKPD(PSJWARD,PSJRBD)
  1. .. I 'PSJQ S PSJX=0 Q
  1. .. D AGY
  1. Q:'PSJQ
  1. N XX,HL,HLFS,HLECH M HL=NHL
  1. S HLFS=NHL("FS")
  1. S HLECH=NHL("ECH")
  1. N ZTIO,ZTRTN,ZTSAVE,ZTDESC,ZTDTH
  1. S ZTIO=""
  1. S ZTRTN="SEND^PSJPDCL"
  1. F XX="PSJQ(","NSEG(","HLFS","HLECH","HL(","SNM","SID","FTS" S ZTSAVE(XX)=""
  1. S ZTDESC="PADE HL7 ADT Message Router"
  1. S ZTDTH=$H
  1. D ^%ZTLOAD
  1. Q
  1. ;
  1. SEND ;
  1. N XX,CT,PSJND,PSJVNM,PSJDNS,PSJVP,VR,HLA,CNM,PSJSND
  1. M HLA("HLS")=NSEG
  1. Q:$G(SNM)=""
  1. I $G(HL("ETN"))="" D INIT^HLFNC2(SNM,.HL) Q:$D(HL)=1
  1. S CNM="PSJ ADT-"_HL("ETN")_" CLIENT"
  1. S XX=0,CT=0 F S XX=$O(PSJQ(XX)) Q:'XX D ;sends HL7 message for each PADE SERVER
  1. .S PSJND=$G(^PS(58.7,XX,0))
  1. .Q:PSJND=""
  1. .S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
  1. .Q:PSJVNM=""!(PSJDNS="")!('PSJVP)
  1. .N HLP,PSJSND,ZZ1,ZZ2 S (HLP,ZZ1,ZZ2)=""
  1. .I $G(HL("ETN"))="" D INIT^HLFNC2(SNM,.HL) Q:$D(HL)=1
  1. .K HLA,HLL M HLA("HLS")=NSEG
  1. .S HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
  1. .S HLL("LINKS",1)=CNM_"^"_"PSJ PADE",ZZ1=$P(PSJQ(XX),"^",2)
  1. .S CT=$O(HLA("HLS",9999),-1)+1 S:CT>1 HLA("HLS",CT)="ZZZ"_HL("FS")_ZZ1_HL("FS")_HL("FS")_FTS
  1. .D PV19^PSJPDAPP
  1. .D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
  1. .S:$G(PSJSND(1)) PSJSND=PSJSND(1)
  1. .D LOG^PSJPADE
  1. Q
  1. ;
  1. TR(SEG) ; Translate the VAFC message delimiters to HL7 delimiters for PADE
  1. N CSEG
  1. S CSEG=$TR(SEG,HL("FS")_HL("ECH"),NHL("FS")_NHL("ECH"))
  1. S CSEG=$TR(CSEG,"""","")
  1. Q CSEG
  1. ;
  1. CHKPD(PSJWD,PSJRB) ;
  1. N PSJWDI S PSJWDI=$O(^DIC(42,"B",PSJWD,"")) K PSJQ
  1. Q:'PSJWDI 0
  1. N PSJDIV,PSJDIVI S PSJDIV=+$P($G(^DIC(42,PSJWDI,0)),"^",11)
  1. Q:'PSJDIV 0
  1. N PSJPD,PSJSAR,PSJX S (PSJQ,PSJPD)=0
  1. F S PSJPD=$O(^PS(58.7,"AD",PSJDIV,PSJPD)) Q:'PSJPD D
  1. . Q:'$D(PSJAP(PSJPD))
  1. . S PSJDIVI=$O(^PS(58.7,PSJPD,"DIV","B",PSJDIV,0))
  1. . Q:'PSJDIVI
  1. . N DN S DN=$G(^PS(58.7,PSJPD,"DIV",PSJDIVI,0))
  1. . S PSJACT=$P(DN,"^",2)
  1. . I PSJACT,PSJACT<DT Q
  1. . I $G(PSJPDO)=1 N I S I=0 D Q:I
  1. .. I ($P($G(^PS(58.7,PSJPD,"DIV",PSJDIVI,2)),"^"))'="Y" S I=1 Q ;DON'T SEND ORDER MESSAGES
  1. .. I $G(RXO)["V",$P(DN,"^",5)'="Y" S I=1 Q ;DON'T SEND IP IV
  1. .. I "UV"[$E(RXO,$L(RXO)),($P($G(^(3)),"^")="Y"),'($S(RXO["V":$$CSIV^PSJPDCLA,1:$$CSUD^PSJPDCLA)) S I=1 Q ;CS ONLY
  1. . S PSJX=0
  1. . I $G(PSJRB)]"" D
  1. .. N PSJRBI S PSJRBI=$$ROOMBED(PSJRB,PSJWDI) I 'PSJRBI Q
  1. .. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIVI,"BG","C",PSJRBI,0))
  1. .. I PSJSAR D
  1. ... S PSJSAR=$G(^PS(58.7,PSJPD,"DIV",PSJDIVI,"BG",PSJSAR,2))
  1. ... I PSJSAR S PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^") S:PSJSAR]"" PSJQ(PSJPD)="1^"_PSJSAR,(PSJX,PSJQ)=1,PSJXCL(PSJPD)=1
  1. . Q:PSJX
  1. . S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WD","B",PSJWDI,0))
  1. . I PSJSAR D
  1. .. S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WD",PSJSAR,0)),"^",2)
  1. .. S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
  1. .. S PSJQ(PSJPD)=1_$S(PSJSAR]"":"^"_PSJSAR,1:""),(PSJX,PSJQ)=1,PSJXCL(PSJPD)=1
  1. . Q:PSJX
  1. . I $O(^PS(57.5,"AB",PSJWDI,0)) D
  1. .. S PSJSAR=$O(^PS(57.5,"AB",PSJWDI,0)) Q:'PSJSAR
  1. .. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WG","B",PSJSAR,0))
  1. .. I PSJSAR S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WG",PSJSAR,0)),"^",2) D
  1. ... S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
  1. ... S PSJQ(PSJPD)="1"_$S(PSJSAR]"":"^"_PSJSAR,1:""),(PSJQ,PSJX)=1,PSJXCL(PSJPD)=1
  1. . K:'PSJX PSJAP(PSJPD)
  1. Q PSJQ
  1. ;
  1. REACT ;
  1. N REAC S REAC="",IDX=0
  1. F S IDX=$O(ADTL("S",IDX)) Q:IDX="" D
  1. . I IDX>1 S REAC=REAC_NECH_$G(ADTL("S",IDX))
  1. . E S REAC=$G(ADTL("S",IDX))
  1. S:REAC]"" $P(SEG,NFS,6)=REAC
  1. Q
  1. ;
  1. AGY ;
  1. N SEG,GMRA,GMRAL
  1. S GMRA="0^0^111" D ^GMRADPT
  1. I GMRAL="" G OBX
  1. ;No known
  1. I GMRAL=0 D
  1. .S $P(SEG,NFS,1)="AL1"
  1. .S $P(SEG,NFS,2)=1
  1. .S $P(SEG,NFS,3)="OA"
  1. .S $P(SEG,NFS,4)="0;GMRD(120.82,"_NECH_"NO KNOWN ALLERGIES"
  1. .S $P(SEG,NFS,6)=""
  1. .S $P(SEG,NFS,7)=$$FMTHL7^XLFDT($$GET1^DIQ(120.86,DFN,3,"I"))
  1. .S SEQ=SEQ+1
  1. .S NSEG(SEQ)=SEG
  1. ;
  1. ;Yes, allergies
  1. I GMRAL=1 N KK,ACT,AEXT,ND D
  1. .S KK=0,ACT=0
  1. .F S KK=$O(GMRAL(KK)) Q:'KK D
  1. ..S ND=GMRAL(KK)
  1. ..S AEXT=$P(ND,U,2)
  1. ..S ACT=ACT+1
  1. ..S $P(SEG,NFS,1)="AL1"
  1. ..S $P(SEG,NFS,2)=ACT
  1. ..S $P(SEG,NFS,3)=$S($P(ND,U,3)="D":"DA",$P(ND,U,3)="F":"FA",1:"OA")
  1. ..S $P(SEG,NFS,4)=$P(ND,U,9)_NECH_AEXT
  1. ..N ADTL D EN1^GMRAOR2(KK,"ADTL") D:$O(ADTL("O",""))
  1. ... N IDX,SEV
  1. ... S IDX=$O(ADTL("O","")),SEV=$P($G(ADTL("O",IDX)),"^",2)
  1. ... S SEV=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U")
  1. ... S $P(SEG,NFS,5)=SEV
  1. ..D:$O(ADTL("S","")) REACT
  1. ..S $P(SEG,NFS,7)=$$FMTHL7^XLFDT($$GET1^DIQ(120.8,KK,4,"I"))
  1. ..S SEQ=SEQ+1
  1. ..S NSEG(SEQ)=SEG,SEG=""
  1. OBX ;HT,WT
  1. N GMRVSTR
  1. S GMRVSTR="HT" D EN6^GMRVUTL
  1. I X]"" S $P(SEG,NFS,1)="OBX",$P(SEG,NFS,2)=1,$P(SEG,NFS,3)="CE",$P(SEG,NFS,4)="1010.3"_NECH_"HEIGHT" D
  1. .S $P(SEG,NFS,6)=$J($P(X,U,8)*2.54,0,2),$P(SEG,NFS,7)="cm"
  1. .S $P(SEG,NFS,15)=$$HLDATE^HLFNC($P(X,U))
  1. .S SEQ=SEQ+1
  1. .S NSEG(SEQ)=SEG,SEG=""
  1. S GMRVSTR="WT" D EN6^GMRVUTL
  1. I X]"" S $P(SEG,NFS,1)="OBX",$P(SEG,NFS,2)=2,$P(SEG,NFS,3)="CE",$P(SEG,NFS,4)="1010.1"_NECH_"WEIGHT" D
  1. .S $P(SEG,NFS,6)=$J($P(X,U,8)/2.2046226,0,2),$P(SEG,NFS,7)="kg"
  1. .S $P(SEG,NFS,15)=$$HLDATE^HLFNC($P(X,"^"))
  1. .S SEQ=SEQ+1
  1. .S NSEG(SEQ)=SEG,SEG=""
  1. Q
  1. ;
  1. A08 ;
  1. K ^TMP("A08")
  1. M ^TMP("A08","HLS")=^TMP("HLS",$J)
  1. M ^TMP("A08","HL")=HL
  1. Q:$O(^PS(58.7,"B",""))=""
  1. Q:$D(HL)=1
  1. Q:'$D(^TMP("HLS",$J))
  1. N XX,HLN,PSJND,PSJCLN,PSJCLNI,PSJDIV,PSJX S (PSJX,XX)=0
  1. F S XX=$O(^TMP("HLS",$J,XX)) Q:'XX!(PSJX) D
  1. . S HLN=^TMP("HLS",$J,XX)
  1. . I $E(HLN,1,3)="PV1" D
  1. .. S PSJCLN=$P(HLN,FS,4)
  1. .. S PSJCLNI=$O(^SC("B",PSJCLN,0))
  1. .. I 'PSJCLNI S PSJX=1 Q
  1. .. S PSJDIV=$P($G(^SC(PSJCLNI,0)),"^",15)
  1. .. I 'PSJDIV S PSJX=1 Q
  1. .. N PSJPD,PSJSAR,PSJQ S (PSJQ,PSJPD)=0
  1. .. F S PSJPD=$O(^PS(58.7,"AD",PSJDIV,PSJPD)) Q:'PSJPD D
  1. ... I '$D(^PS(58.7,PSJPD,0)) Q
  1. ... N PSJVNM,PSJDNS,PSJVP,PSJACT S PSJND=$G(^PS(58.7,PSJPD,0))
  1. ... S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
  1. ... I PSJVNM=""!(PSJDNS="")!('PSJVP) Q
  1. ... S PSJACT=$P(PSJND,"^",4)
  1. ... I PSJACT&(PSJACT<DT) Q
  1. ... S PSJDIVI=$O(^PS(58.7,PSJPD,"DIV","B",PSJDIV,0))
  1. ... S PSJACT=$G(^PS(58.7,PSJPD,"DIV",PSJDIVI,0))
  1. ... S PSJACT=$P(PSJACT,"^",2)
  1. ... I PSJACT,PSJACT<DT Q
  1. ... S PSJQ=1,PSJQ(PSJPD)=1
  1. Q:'PSJQ
  1. N SNM,SID S SNM="PSJ ADT-A08 SERVER"
  1. S SID=$O(^ORD(101,"B",SNM,0))
  1. Q:'SID
  1. D INIT^HLFNC2(SID,.NHL) Q:$D(NHL)=1
  1. N NFS,NECH S NFS=NHL("FS"),NECH=$E(NHL("ECH"),1)
  1. Q
  1. ;
  1. ROOMBED(RMBDNAM,WARDIEN) ; Return the Room-Bed IEN - 379
  1. N ROOMBED,RMBD
  1. S (RMBD,ROOMBED)=0
  1. F S RMBD=$O(^DG(405.4,"B",RMBDNAM,RMBD)) Q:'RMBD D I ROOMBED Q
  1. . I $D(^DG(405.4,RMBD,"W","B",WARDIEN)) S ROOMBED=RMBD
  1. Q ROOMBED
  1. ;