- PSJPDCL ;BIR/MHA - PADE HL7 ADT MESSAGE CLIENT TO VAFC ADT SERVER ;07/08/15
- ;;5.0;INPATIENT MEDICATIONS;**317,337,347,379,389**;16 DEC 97;Build 4
- ;Reference to ^SC supported by DBIA 10040
- ;Reference to ^DIC(42 supported by DBIA 10039
- ;Reference to ^ORD(101 supported by DBIA 872
- ;Reference to ^DG(405.4 supported by DBIA 1380
- ;Reference to ^GMRADPT supported by DBIA 10099
- ;Reference to ^GMRVUTL supported by DBIA 1120
- ;Reference to ^GMRAOR2 supported by DBIA 2422
- ;
- Q
- ;
- EN ; Get ADT Message and send to PADE.
- Q:$O(^PS(58.7,"B",""))=""
- Q:'$G(HLEID)
- N PSJAP
- S PSJAP=0
- N I,J S I=0
- F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
- Q:'PSJAP
- 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,SID,NHL S SNM="PSJ ADT-"_HL("ETN")_" SERVER"
- S SID=$O(^ORD(101,"B",SNM,0))
- Q:'SID
- D INIT^HLFNC2(SID,.NHL) Q:$D(NHL)=1
- N NFS,NECH S NFS=NHL("FS"),NECH=$E(NHL("ECH"),1)
- N NSEG,PSJQ,PSJLOC,PSJWARD,PSJRBD,SEQ,PSJX,VAIP,X,FTS
- 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:"")
- S SEQ=0,PSJQ=0,PSJX=1 S:HL("ETN")="A11" FTS=""
- F I=1:1 X HLNEXT Q:HLQUIT'>0!('PSJX) D
- . Q:$E(HLNODE,1,3)="MSH"
- . Q:$E(HLNODE,1,3)="OBX"
- . Q:$E(HLNODE,1,3)="ROL"
- . Q:$E(HLNODE,1)="Z"
- . S SEQ=SEQ+1
- . S NSEG(SEQ)=$$TR(HLNODE)
- . S J=0 F S J=$O(HLNODE(J)) Q:'J S NSEG(SEQ,J)=$$TR(HLNODE(J))
- . I $E(HLNODE,1,3)="PV1" D
- .. S PSJLOC=$P(HLNODE,FS,4)
- .. S PSJWARD=$P(PSJLOC,ECH) Q:PSJWARD=""
- .. S PSJQ=$$CHKPD(PSJWARD,PSJRBD)
- .. I 'PSJQ S PSJX=0 Q
- .. D AGY
- Q:'PSJQ
- N XX,HL,HLFS,HLECH M HL=NHL
- S HLFS=NHL("FS")
- S HLECH=NHL("ECH")
- N ZTIO,ZTRTN,ZTSAVE,ZTDESC,ZTDTH
- S ZTIO=""
- S ZTRTN="SEND^PSJPDCL"
- F XX="PSJQ(","NSEG(","HLFS","HLECH","HL(","SNM","SID","FTS" S ZTSAVE(XX)=""
- S ZTDESC="PADE HL7 ADT Message Router"
- S ZTDTH=$H
- D ^%ZTLOAD
- Q
- ;
- SEND ;
- N XX,CT,PSJND,PSJVNM,PSJDNS,PSJVP,VR,HLA,CNM,PSJSND
- M HLA("HLS")=NSEG
- Q:$G(SNM)=""
- I $G(HL("ETN"))="" D INIT^HLFNC2(SNM,.HL) Q:$D(HL)=1
- S CNM="PSJ ADT-"_HL("ETN")_" CLIENT"
- S XX=0,CT=0 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,ZZ1,ZZ2 S (HLP,ZZ1,ZZ2)=""
- .I $G(HL("ETN"))="" D INIT^HLFNC2(SNM,.HL) Q:$D(HL)=1
- .K HLA,HLL M HLA("HLS")=NSEG
- .S HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
- .S HLL("LINKS",1)=CNM_"^"_"PSJ PADE",ZZ1=$P(PSJQ(XX),"^",2)
- .S CT=$O(HLA("HLS",9999),-1)+1 S:CT>1 HLA("HLS",CT)="ZZZ"_HL("FS")_ZZ1_HL("FS")_HL("FS")_FTS
- .D PV19^PSJPDAPP
- .D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
- .S:$G(PSJSND(1)) PSJSND=PSJSND(1)
- .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
- ;
- CHKPD(PSJWD,PSJRB) ;
- N PSJWDI S PSJWDI=$O(^DIC(42,"B",PSJWD,"")) K PSJQ
- Q:'PSJWDI 0
- N PSJDIV,PSJDIVI S PSJDIV=+$P($G(^DIC(42,PSJWDI,0)),"^",11)
- Q:'PSJDIV 0
- N PSJPD,PSJSAR,PSJX S (PSJQ,PSJPD)=0
- F S PSJPD=$O(^PS(58.7,"AD",PSJDIV,PSJPD)) Q:'PSJPD D
- . Q:'$D(PSJAP(PSJPD))
- . S PSJDIVI=$O(^PS(58.7,PSJPD,"DIV","B",PSJDIV,0))
- . Q:'PSJDIVI
- . N DN S DN=$G(^PS(58.7,PSJPD,"DIV",PSJDIVI,0))
- . S PSJACT=$P(DN,"^",2)
- . I PSJACT,PSJACT<DT Q
- . I $G(PSJPDO)=1 N I S I=0 D Q:I
- .. I ($P($G(^PS(58.7,PSJPD,"DIV",PSJDIVI,2)),"^"))'="Y" S I=1 Q ;DON'T SEND ORDER MESSAGES
- .. I $G(RXO)["V",$P(DN,"^",5)'="Y" S I=1 Q ;DON'T SEND IP IV
- .. I "UV"[$E(RXO,$L(RXO)),($P($G(^(3)),"^")="Y"),'($S(RXO["V":$$CSIV^PSJPDCLA,1:$$CSUD^PSJPDCLA)) S I=1 Q ;CS ONLY
- . S PSJX=0
- . I $G(PSJRB)]"" D
- .. N PSJRBI S PSJRBI=$$ROOMBED(PSJRB,PSJWDI) I 'PSJRBI Q
- .. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIVI,"BG","C",PSJRBI,0))
- .. I PSJSAR D
- ... S PSJSAR=$G(^PS(58.7,PSJPD,"DIV",PSJDIVI,"BG",PSJSAR,2))
- ... I PSJSAR S PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^") S:PSJSAR]"" PSJQ(PSJPD)="1^"_PSJSAR,(PSJX,PSJQ)=1,PSJXCL(PSJPD)=1
- . Q:PSJX
- . S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WD","B",PSJWDI,0))
- . I PSJSAR D
- .. S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WD",PSJSAR,0)),"^",2)
- .. S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
- .. S PSJQ(PSJPD)=1_$S(PSJSAR]"":"^"_PSJSAR,1:""),(PSJX,PSJQ)=1,PSJXCL(PSJPD)=1
- . Q:PSJX
- . I $O(^PS(57.5,"AB",PSJWDI,0)) D
- .. S PSJSAR=$O(^PS(57.5,"AB",PSJWDI,0)) Q:'PSJSAR
- .. S PSJSAR=$O(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WG","B",PSJSAR,0))
- .. I PSJSAR S PSJSAR=$P($G(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WG",PSJSAR,0)),"^",2) D
- ... S:PSJSAR PSJSAR=$P($G(^PS(58.71,PSJSAR,0)),"^")
- ... S PSJQ(PSJPD)="1"_$S(PSJSAR]"":"^"_PSJSAR,1:""),(PSJQ,PSJX)=1,PSJXCL(PSJPD)=1
- . K:'PSJX PSJAP(PSJPD)
- Q PSJQ
- ;
- REACT ;
- N REAC S REAC="",IDX=0
- F S IDX=$O(ADTL("S",IDX)) Q:IDX="" D
- . I IDX>1 S REAC=REAC_NECH_$G(ADTL("S",IDX))
- . E S REAC=$G(ADTL("S",IDX))
- S:REAC]"" $P(SEG,NFS,6)=REAC
- Q
- ;
- AGY ;
- N SEG,GMRA,GMRAL
- S GMRA="0^0^111" D ^GMRADPT
- I GMRAL="" G OBX
- ;No known
- I GMRAL=0 D
- .S $P(SEG,NFS,1)="AL1"
- .S $P(SEG,NFS,2)=1
- .S $P(SEG,NFS,3)="OA"
- .S $P(SEG,NFS,4)="0;GMRD(120.82,"_NECH_"NO KNOWN ALLERGIES"
- .S $P(SEG,NFS,6)=""
- .S $P(SEG,NFS,7)=$$FMTHL7^XLFDT($$GET1^DIQ(120.86,DFN,3,"I"))
- .S SEQ=SEQ+1
- .S NSEG(SEQ)=SEG
- ;
- ;Yes, allergies
- I GMRAL=1 N KK,ACT,AEXT,ND D
- .S KK=0,ACT=0
- .F S KK=$O(GMRAL(KK)) Q:'KK D
- ..S ND=GMRAL(KK)
- ..S AEXT=$P(ND,U,2)
- ..S ACT=ACT+1
- ..S $P(SEG,NFS,1)="AL1"
- ..S $P(SEG,NFS,2)=ACT
- ..S $P(SEG,NFS,3)=$S($P(ND,U,3)="D":"DA",$P(ND,U,3)="F":"FA",1:"OA")
- ..S $P(SEG,NFS,4)=$P(ND,U,9)_NECH_AEXT
- ..N ADTL D EN1^GMRAOR2(KK,"ADTL") D:$O(ADTL("O",""))
- ... N IDX,SEV
- ... S IDX=$O(ADTL("O","")),SEV=$P($G(ADTL("O",IDX)),"^",2)
- ... S SEV=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U")
- ... S $P(SEG,NFS,5)=SEV
- ..D:$O(ADTL("S","")) REACT
- ..S $P(SEG,NFS,7)=$$FMTHL7^XLFDT($$GET1^DIQ(120.8,KK,4,"I"))
- ..S SEQ=SEQ+1
- ..S NSEG(SEQ)=SEG,SEG=""
- OBX ;HT,WT
- N GMRVSTR
- S GMRVSTR="HT" D EN6^GMRVUTL
- 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
- .S $P(SEG,NFS,6)=$J($P(X,U,8)*2.54,0,2),$P(SEG,NFS,7)="cm"
- .S $P(SEG,NFS,15)=$$HLDATE^HLFNC($P(X,U))
- .S SEQ=SEQ+1
- .S NSEG(SEQ)=SEG,SEG=""
- S GMRVSTR="WT" D EN6^GMRVUTL
- 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
- .S $P(SEG,NFS,6)=$J($P(X,U,8)/2.2046226,0,2),$P(SEG,NFS,7)="kg"
- .S $P(SEG,NFS,15)=$$HLDATE^HLFNC($P(X,"^"))
- .S SEQ=SEQ+1
- .S NSEG(SEQ)=SEG,SEG=""
- Q
- ;
- A08 ;
- K ^TMP("A08")
- M ^TMP("A08","HLS")=^TMP("HLS",$J)
- M ^TMP("A08","HL")=HL
- Q:$O(^PS(58.7,"B",""))=""
- Q:$D(HL)=1
- Q:'$D(^TMP("HLS",$J))
- N XX,HLN,PSJND,PSJCLN,PSJCLNI,PSJDIV,PSJX S (PSJX,XX)=0
- F S XX=$O(^TMP("HLS",$J,XX)) Q:'XX!(PSJX) D
- . S HLN=^TMP("HLS",$J,XX)
- . I $E(HLN,1,3)="PV1" D
- .. S PSJCLN=$P(HLN,FS,4)
- .. S PSJCLNI=$O(^SC("B",PSJCLN,0))
- .. I 'PSJCLNI S PSJX=1 Q
- .. S PSJDIV=$P($G(^SC(PSJCLNI,0)),"^",15)
- .. I 'PSJDIV S PSJX=1 Q
- .. N PSJPD,PSJSAR,PSJQ S (PSJQ,PSJPD)=0
- .. F S PSJPD=$O(^PS(58.7,"AD",PSJDIV,PSJPD)) Q:'PSJPD D
- ... I '$D(^PS(58.7,PSJPD,0)) Q
- ... N PSJVNM,PSJDNS,PSJVP,PSJACT 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
- ... S PSJACT=$P(PSJND,"^",4)
- ... I PSJACT&(PSJACT<DT) Q
- ... S PSJDIVI=$O(^PS(58.7,PSJPD,"DIV","B",PSJDIV,0))
- ... S PSJACT=$G(^PS(58.7,PSJPD,"DIV",PSJDIVI,0))
- ... S PSJACT=$P(PSJACT,"^",2)
- ... I PSJACT,PSJACT<DT Q
- ... S PSJQ=1,PSJQ(PSJPD)=1
- Q:'PSJQ
- N SNM,SID S SNM="PSJ ADT-A08 SERVER"
- S SID=$O(^ORD(101,"B",SNM,0))
- Q:'SID
- D INIT^HLFNC2(SID,.NHL) Q:$D(NHL)=1
- N NFS,NECH S NFS=NHL("FS"),NECH=$E(NHL("ECH"),1)
- Q
- ;
- ROOMBED(RMBDNAM,WARDIEN) ; Return the Room-Bed IEN - 379
- N ROOMBED,RMBD
- S (RMBD,ROOMBED)=0
- F S RMBD=$O(^DG(405.4,"B",RMBDNAM,RMBD)) Q:'RMBD D I ROOMBED Q
- . I $D(^DG(405.4,RMBD,"W","B",WARDIEN)) S ROOMBED=RMBD
- Q ROOMBED
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDCL 8167 printed Feb 18, 2025@23:35:04 Page 2
- 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
- +2 ;Reference to ^SC supported by DBIA 10040
- +3 ;Reference to ^DIC(42 supported by DBIA 10039
- +4 ;Reference to ^ORD(101 supported by DBIA 872
- +5 ;Reference to ^DG(405.4 supported by DBIA 1380
- +6 ;Reference to ^GMRADPT supported by DBIA 10099
- +7 ;Reference to ^GMRVUTL supported by DBIA 1120
- +8 ;Reference to ^GMRAOR2 supported by DBIA 2422
- +9 ;
- +10 QUIT
- +11 ;
- EN ; Get ADT Message and send to PADE.
- +1 if $ORDER(^PS(58.7,"B",""))=""
- QUIT
- +2 if '$GET(HLEID)
- QUIT
- +3 NEW PSJAP
- +4 SET PSJAP=0
- +5 NEW I,J
- SET I=0
- +6 FOR
- SET I=$ORDER(^PS(58.7,I))
- if 'I
- QUIT
- SET J=$$PDACT^PSJPDCLA(I)
- +7 if 'PSJAP
- 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,SID,NHL
- SET SNM="PSJ ADT-"_HL("ETN")_" SERVER"
- +11 SET SID=$ORDER(^ORD(101,"B",SNM,0))
- +12 if 'SID
- QUIT
- +13 DO INIT^HLFNC2(SID,.NHL)
- if $DATA(NHL)=1
- QUIT
- +14 NEW NFS,NECH
- SET NFS=NHL("FS")
- SET NECH=$EXTRACT(NHL("ECH"),1)
- +15 NEW NSEG,PSJQ,PSJLOC,PSJWARD,PSJRBD,SEQ,PSJX,VAIP,X,FTS
- +16 SET VAIP("D")="L"
- DO IN5^VADPT
- SET PSJRBD=$PIECE(VAIP(6),"^",2)
- SET FTS=$SELECT($PIECE(VAIP(8),"^")]"":$PIECE(VAIP(8),"^")_NECH_$PIECE(VAIP(8),"^",2),1:"")
- +17 SET SEQ=0
- SET PSJQ=0
- SET PSJX=1
- if HL("ETN")="A11"
- SET FTS=""
- +18 FOR I=1:1
- XECUTE HLNEXT
- if HLQUIT'>0!('PSJX)
- QUIT
- Begin DoDot:1
- +19 if $EXTRACT(HLNODE,1,3)="MSH"
- QUIT
- +20 if $EXTRACT(HLNODE,1,3)="OBX"
- QUIT
- +21 if $EXTRACT(HLNODE,1,3)="ROL"
- QUIT
- +22 if $EXTRACT(HLNODE,1)="Z"
- QUIT
- +23 SET SEQ=SEQ+1
- +24 SET NSEG(SEQ)=$$TR(HLNODE)
- +25 SET J=0
- FOR
- SET J=$ORDER(HLNODE(J))
- if 'J
- QUIT
- SET NSEG(SEQ,J)=$$TR(HLNODE(J))
- +26 IF $EXTRACT(HLNODE,1,3)="PV1"
- Begin DoDot:2
- +27 SET PSJLOC=$PIECE(HLNODE,FS,4)
- +28 SET PSJWARD=$PIECE(PSJLOC,ECH)
- if PSJWARD=""
- QUIT
- +29 SET PSJQ=$$CHKPD(PSJWARD,PSJRBD)
- +30 IF 'PSJQ
- SET PSJX=0
- QUIT
- +31 DO AGY
- End DoDot:2
- End DoDot:1
- +32 if 'PSJQ
- QUIT
- +33 NEW XX,HL,HLFS,HLECH
- MERGE HL=NHL
- +34 SET HLFS=NHL("FS")
- +35 SET HLECH=NHL("ECH")
- +36 NEW ZTIO,ZTRTN,ZTSAVE,ZTDESC,ZTDTH
- +37 SET ZTIO=""
- +38 SET ZTRTN="SEND^PSJPDCL"
- +39 FOR XX="PSJQ(","NSEG(","HLFS","HLECH","HL(","SNM","SID","FTS"
- SET ZTSAVE(XX)=""
- +40 SET ZTDESC="PADE HL7 ADT Message Router"
- +41 SET ZTDTH=$HOROLOG
- +42 DO ^%ZTLOAD
- +43 QUIT
- +44 ;
- SEND ;
- +1 NEW XX,CT,PSJND,PSJVNM,PSJDNS,PSJVP,VR,HLA,CNM,PSJSND
- +2 MERGE HLA("HLS")=NSEG
- +3 if $GET(SNM)=""
- QUIT
- +4 IF $GET(HL("ETN"))=""
- DO INIT^HLFNC2(SNM,.HL)
- if $DATA(HL)=1
- QUIT
- +5 SET CNM="PSJ ADT-"_HL("ETN")_" CLIENT"
- +6 ;sends HL7 message for each PADE SERVER
- SET XX=0
- SET CT=0
- FOR
- SET XX=$ORDER(PSJQ(XX))
- if 'XX
- QUIT
- Begin DoDot:1
- +7 SET PSJND=$GET(^PS(58.7,XX,0))
- +8 if PSJND=""
- QUIT
- +9 SET PSJVNM=$PIECE(PSJND,"^")
- SET PSJDNS=$PIECE(PSJND,"^",2)
- SET PSJVP=$PIECE(PSJND,"^",3)
- +10 if PSJVNM=""!(PSJDNS="")!('PSJVP)
- QUIT
- +11 NEW HLP,PSJSND,ZZ1,ZZ2
- SET (HLP,ZZ1,ZZ2)=""
- +12 IF $GET(HL("ETN"))=""
- DO INIT^HLFNC2(SNM,.HL)
- if $DATA(HL)=1
- QUIT
- +13 KILL HLA,HLL
- MERGE HLA("HLS")=NSEG
- +14 SET HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
- +15 SET HLL("LINKS",1)=CNM_"^"_"PSJ PADE"
- SET ZZ1=$PIECE(PSJQ(XX),"^",2)
- +16 SET CT=$ORDER(HLA("HLS",9999),-1)+1
- if CT>1
- SET HLA("HLS",CT)="ZZZ"_HL("FS")_ZZ1_HL("FS")_HL("FS")_FTS
- +17 DO PV19^PSJPDAPP
- +18 DO GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
- +19 if $GET(PSJSND(1))
- SET PSJSND=PSJSND(1)
- +20 DO LOG^PSJPADE
- End DoDot:1
- +21 QUIT
- +22 ;
- 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 ;
- CHKPD(PSJWD,PSJRB) ;
- +1 NEW PSJWDI
- SET PSJWDI=$ORDER(^DIC(42,"B",PSJWD,""))
- KILL PSJQ
- +2 if 'PSJWDI
- QUIT 0
- +3 NEW PSJDIV,PSJDIVI
- SET PSJDIV=+$PIECE($GET(^DIC(42,PSJWDI,0)),"^",11)
- +4 if 'PSJDIV
- QUIT 0
- +5 NEW PSJPD,PSJSAR,PSJX
- SET (PSJQ,PSJPD)=0
- +6 FOR
- SET PSJPD=$ORDER(^PS(58.7,"AD",PSJDIV,PSJPD))
- if 'PSJPD
- QUIT
- Begin DoDot:1
- +7 if '$DATA(PSJAP(PSJPD))
- QUIT
- +8 SET PSJDIVI=$ORDER(^PS(58.7,PSJPD,"DIV","B",PSJDIV,0))
- +9 if 'PSJDIVI
- QUIT
- +10 NEW DN
- SET DN=$GET(^PS(58.7,PSJPD,"DIV",PSJDIVI,0))
- +11 SET PSJACT=$PIECE(DN,"^",2)
- +12 IF PSJACT
- IF PSJACT<DT
- QUIT
- +13 IF $GET(PSJPDO)=1
- NEW I
- SET I=0
- Begin DoDot:2
- +14 ;DON'T SEND ORDER MESSAGES
- IF ($PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIVI,2)),"^"))'="Y"
- SET I=1
- QUIT
- +15 ;DON'T SEND IP IV
- IF $GET(RXO)["V"
- IF $PIECE(DN,"^",5)'="Y"
- SET I=1
- QUIT
- +16 ;CS ONLY
- IF "UV"[$EXTRACT(RXO,$LENGTH(RXO))
- IF ($PIECE($GET(^(3)),"^")="Y")
- IF '($SELECT(RXO["V":$$CSIV^PSJPDCLA,1:$$CSUD^PSJPDCLA))
- SET I=1
- QUIT
- End DoDot:2
- if I
- QUIT
- +17 SET PSJX=0
- +18 IF $GET(PSJRB)]""
- Begin DoDot:2
- +19 NEW PSJRBI
- SET PSJRBI=$$ROOMBED(PSJRB,PSJWDI)
- IF 'PSJRBI
- QUIT
- +20 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIVI,"BG","C",PSJRBI,0))
- +21 IF PSJSAR
- Begin DoDot:3
- +22 SET PSJSAR=$GET(^PS(58.7,PSJPD,"DIV",PSJDIVI,"BG",PSJSAR,2))
- +23 IF PSJSAR
- SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
- if PSJSAR]""
- SET PSJQ(PSJPD)="1^"_PSJSAR
- SET (PSJX,PSJQ)=1
- SET PSJXCL(PSJPD)=1
- End DoDot:3
- End DoDot:2
- +24 if PSJX
- QUIT
- +25 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WD","B",PSJWDI,0))
- +26 IF PSJSAR
- Begin DoDot:2
- +27 SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WD",PSJSAR,0)),"^",2)
- +28 if PSJSAR
- SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
- +29 SET PSJQ(PSJPD)=1_$SELECT(PSJSAR]"":"^"_PSJSAR,1:"")
- SET (PSJX,PSJQ)=1
- SET PSJXCL(PSJPD)=1
- End DoDot:2
- +30 if PSJX
- QUIT
- +31 IF $ORDER(^PS(57.5,"AB",PSJWDI,0))
- Begin DoDot:2
- +32 SET PSJSAR=$ORDER(^PS(57.5,"AB",PSJWDI,0))
- if 'PSJSAR
- QUIT
- +33 SET PSJSAR=$ORDER(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WG","B",PSJSAR,0))
- +34 IF PSJSAR
- SET PSJSAR=$PIECE($GET(^PS(58.7,PSJPD,"DIV",PSJDIVI,"WG",PSJSAR,0)),"^",2)
- Begin DoDot:3
- +35 if PSJSAR
- SET PSJSAR=$PIECE($GET(^PS(58.71,PSJSAR,0)),"^")
- +36 SET PSJQ(PSJPD)="1"_$SELECT(PSJSAR]"":"^"_PSJSAR,1:"")
- SET (PSJQ,PSJX)=1
- SET PSJXCL(PSJPD)=1
- End DoDot:3
- End DoDot:2
- +37 if 'PSJX
- KILL PSJAP(PSJPD)
- End DoDot:1
- +38 QUIT PSJQ
- +39 ;
- REACT ;
- +1 NEW REAC
- SET REAC=""
- SET IDX=0
- +2 FOR
- SET IDX=$ORDER(ADTL("S",IDX))
- if IDX=""
- QUIT
- Begin DoDot:1
- +3 IF IDX>1
- SET REAC=REAC_NECH_$GET(ADTL("S",IDX))
- +4 IF '$TEST
- SET REAC=$GET(ADTL("S",IDX))
- End DoDot:1
- +5 if REAC]""
- SET $PIECE(SEG,NFS,6)=REAC
- +6 QUIT
- +7 ;
- AGY ;
- +1 NEW SEG,GMRA,GMRAL
- +2 SET GMRA="0^0^111"
- DO ^GMRADPT
- +3 IF GMRAL=""
- GOTO OBX
- +4 ;No known
- +5 IF GMRAL=0
- Begin DoDot:1
- +6 SET $PIECE(SEG,NFS,1)="AL1"
- +7 SET $PIECE(SEG,NFS,2)=1
- +8 SET $PIECE(SEG,NFS,3)="OA"
- +9 SET $PIECE(SEG,NFS,4)="0;GMRD(120.82,"_NECH_"NO KNOWN ALLERGIES"
- +10 SET $PIECE(SEG,NFS,6)=""
- +11 SET $PIECE(SEG,NFS,7)=$$FMTHL7^XLFDT($$GET1^DIQ(120.86,DFN,3,"I"))
- +12 SET SEQ=SEQ+1
- +13 SET NSEG(SEQ)=SEG
- End DoDot:1
- +14 ;
- +15 ;Yes, allergies
- +16 IF GMRAL=1
- NEW KK,ACT,AEXT,ND
- Begin DoDot:1
- +17 SET KK=0
- SET ACT=0
- +18 FOR
- SET KK=$ORDER(GMRAL(KK))
- if 'KK
- QUIT
- Begin DoDot:2
- +19 SET ND=GMRAL(KK)
- +20 SET AEXT=$PIECE(ND,U,2)
- +21 SET ACT=ACT+1
- +22 SET $PIECE(SEG,NFS,1)="AL1"
- +23 SET $PIECE(SEG,NFS,2)=ACT
- +24 SET $PIECE(SEG,NFS,3)=$SELECT($PIECE(ND,U,3)="D":"DA",$PIECE(ND,U,3)="F":"FA",1:"OA")
- +25 SET $PIECE(SEG,NFS,4)=$PIECE(ND,U,9)_NECH_AEXT
- +26 NEW ADTL
- DO EN1^GMRAOR2(KK,"ADTL")
- if $ORDER(ADTL("O",""))
- Begin DoDot:3
- +27 NEW IDX,SEV
- +28 SET IDX=$ORDER(ADTL("O",""))
- SET SEV=$PIECE($GET(ADTL("O",IDX)),"^",2)
- +29 SET SEV=$SELECT(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U")
- +30 SET $PIECE(SEG,NFS,5)=SEV
- End DoDot:3
- +31 if $ORDER(ADTL("S",""))
- DO REACT
- +32 SET $PIECE(SEG,NFS,7)=$$FMTHL7^XLFDT($$GET1^DIQ(120.8,KK,4,"I"))
- +33 SET SEQ=SEQ+1
- +34 SET NSEG(SEQ)=SEG
- SET SEG=""
- End DoDot:2
- End DoDot:1
- OBX ;HT,WT
- +1 NEW GMRVSTR
- +2 SET GMRVSTR="HT"
- DO EN6^GMRVUTL
- +3 IF X]""
- SET $PIECE(SEG,NFS,1)="OBX"
- SET $PIECE(SEG,NFS,2)=1
- SET $PIECE(SEG,NFS,3)="CE"
- SET $PIECE(SEG,NFS,4)="1010.3"_NECH_"HEIGHT"
- Begin DoDot:1
- +4 SET $PIECE(SEG,NFS,6)=$JUSTIFY($PIECE(X,U,8)*2.54,0,2)
- SET $PIECE(SEG,NFS,7)="cm"
- +5 SET $PIECE(SEG,NFS,15)=$$HLDATE^HLFNC($PIECE(X,U))
- +6 SET SEQ=SEQ+1
- +7 SET NSEG(SEQ)=SEG
- SET SEG=""
- End DoDot:1
- +8 SET GMRVSTR="WT"
- DO EN6^GMRVUTL
- +9 IF X]""
- SET $PIECE(SEG,NFS,1)="OBX"
- SET $PIECE(SEG,NFS,2)=2
- SET $PIECE(SEG,NFS,3)="CE"
- SET $PIECE(SEG,NFS,4)="1010.1"_NECH_"WEIGHT"
- Begin DoDot:1
- +10 SET $PIECE(SEG,NFS,6)=$JUSTIFY($PIECE(X,U,8)/2.2046226,0,2)
- SET $PIECE(SEG,NFS,7)="kg"
- +11 SET $PIECE(SEG,NFS,15)=$$HLDATE^HLFNC($PIECE(X,"^"))
- +12 SET SEQ=SEQ+1
- +13 SET NSEG(SEQ)=SEG
- SET SEG=""
- End DoDot:1
- +14 QUIT
- +15 ;
- A08 ;
- +1 KILL ^TMP("A08")
- +2 MERGE ^TMP("A08","HLS")=^TMP("HLS",$JOB)
- +3 MERGE ^TMP("A08","HL")=HL
- +4 if $ORDER(^PS(58.7,"B",""))=""
- QUIT
- +5 if $DATA(HL)=1
- QUIT
- +6 if '$DATA(^TMP("HLS",$JOB))
- QUIT
- +7 NEW XX,HLN,PSJND,PSJCLN,PSJCLNI,PSJDIV,PSJX
- SET (PSJX,XX)=0
- +8 FOR
- SET XX=$ORDER(^TMP("HLS",$JOB,XX))
- if 'XX!(PSJX)
- QUIT
- Begin DoDot:1
- +9 SET HLN=^TMP("HLS",$JOB,XX)
- +10 IF $EXTRACT(HLN,1,3)="PV1"
- Begin DoDot:2
- +11 SET PSJCLN=$PIECE(HLN,FS,4)
- +12 SET PSJCLNI=$ORDER(^SC("B",PSJCLN,0))
- +13 IF 'PSJCLNI
- SET PSJX=1
- QUIT
- +14 SET PSJDIV=$PIECE($GET(^SC(PSJCLNI,0)),"^",15)
- +15 IF 'PSJDIV
- SET PSJX=1
- QUIT
- +16 NEW PSJPD,PSJSAR,PSJQ
- SET (PSJQ,PSJPD)=0
- +17 FOR
- SET PSJPD=$ORDER(^PS(58.7,"AD",PSJDIV,PSJPD))
- if 'PSJPD
- QUIT
- Begin DoDot:3
- +18 IF '$DATA(^PS(58.7,PSJPD,0))
- QUIT
- +19 NEW PSJVNM,PSJDNS,PSJVP,PSJACT
- SET PSJND=$GET(^PS(58.7,PSJPD,0))
- +20 SET PSJVNM=$PIECE(PSJND,"^")
- SET PSJDNS=$PIECE(PSJND,"^",2)
- SET PSJVP=$PIECE(PSJND,"^",3)
- +21 IF PSJVNM=""!(PSJDNS="")!('PSJVP)
- QUIT
- +22 SET PSJACT=$PIECE(PSJND,"^",4)
- +23 IF PSJACT&(PSJACT<DT)
- QUIT
- +24 SET PSJDIVI=$ORDER(^PS(58.7,PSJPD,"DIV","B",PSJDIV,0))
- +25 SET PSJACT=$GET(^PS(58.7,PSJPD,"DIV",PSJDIVI,0))
- +26 SET PSJACT=$PIECE(PSJACT,"^",2)
- +27 IF PSJACT
- IF PSJACT<DT
- QUIT
- +28 SET PSJQ=1
- SET PSJQ(PSJPD)=1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +29 if 'PSJQ
- QUIT
- +30 NEW SNM,SID
- SET SNM="PSJ ADT-A08 SERVER"
- +31 SET SID=$ORDER(^ORD(101,"B",SNM,0))
- +32 if 'SID
- QUIT
- +33 DO INIT^HLFNC2(SID,.NHL)
- if $DATA(NHL)=1
- QUIT
- +34 NEW NFS,NECH
- SET NFS=NHL("FS")
- SET NECH=$EXTRACT(NHL("ECH"),1)
- +35 QUIT
- +36 ;
- ROOMBED(RMBDNAM,WARDIEN) ; Return the Room-Bed IEN - 379
- +1 NEW ROOMBED,RMBD
- +2 SET (RMBD,ROOMBED)=0
- +3 FOR
- SET RMBD=$ORDER(^DG(405.4,"B",RMBDNAM,RMBD))
- if 'RMBD
- QUIT
- Begin DoDot:1
- +4 IF $DATA(^DG(405.4,RMBD,"W","B",WARDIEN))
- SET ROOMBED=RMBD
- End DoDot:1
- IF ROOMBED
- QUIT
- +5 QUIT ROOMBED
- +6 ;