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 Dec 13, 2024@02:08:41 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 ;
