PSDADT1 ;BIR/LTL- ADT Admit Message builder for HL7 V 1.6; 24 Nov 95
;;3.0; CONTROLLED SUBSTANCES ;**30**;13 Feb 97
;Reference to ^HLCS(869.2 are covered by DBIA #1495
;Reference to ^ORD(101 are covered by DBIA #872
;Reference to $$EN^VAFHLPID are covered by DBIA #263
;
Q:'$P(DGPMA,U,2)!(("123")'[$P(DGPMA,U,2))
Q:'$P($G(^HLCS(869.2,+$O(^HLCS(869.2,"B","PSD-NDES HLLP",0)),200)),U)&('$P($G(^HLCS(869.2,+$O(^HLCS(869.2,"B","PSD-NDES X3.28",0)),300)),U))
N HLMTN,HLEVN,HLFS,HLA,HL,HLQ,HLECH,PSDHL
SERVER S EID=$O(^ORD(101,"B",$S($P(DGPMA,U,2)=1:"PSD A01 SERVER",$P(DGPMA,U,2)=2:"PSD A02 SERVER",1:"PSD A03 SERVER"),0)),INT=0
D INIT^HLFNC2(EID,.HL,INT)
Q:$O(HL(""))']""
D EVN($P(DGPMA,U,2),$P(DGPMA,U))
S HLMTN="ADT",HLEVN=1,HLFS=HL("FS"),HLECH=HL("ECH"),HLQ=""
PID S HLA("HLS",2)=$$EN^VAFHLPID(DFN,"1,2,3,5")
N PSDSTRN
S PSDSTRN=HLA("HLS",2),$P(PSDSTRN,HLFS,4)=$P(HLA("HLS",2),HLFS,3)
I $L(PSDSTRN)>245 S VAFPID(1)=$E(PSDSTRN,246,999)_$G(VAFPID(1))
S HLA("HLS",2)=$E(PSDSTRN,1,245)
;
PV1 N VAROOT,VAINDT S VAROOT="PSD",VAINDT=$P(DGPMA,U) D INP^VADPT
S $P(HLA("HLS",3),HL("FS"),3)="I"
S $P(HLA("HLS",3),HL("FS"),8)=""
S $P(HLA("HLS",3),HL("FS"))="PV1"
S $P(HLA("HLS",3),HL("FS"),4)=$P(PSD(4),U,2)_$E(HL("ECH"))_$P(PSD(5),"-")_$E(HL("ECH"))_$P(PSD(5),"-",2)
S $P(HLA("HLS",3),HL("FS"),7)=$E(HL("ECH"))_$E(HL("ECH"))
S $P(HLA("HLS",3),HL("FS"),8)=$P(PSD(2),U)_$E(HL("ECH"))_$$HLNAME^HLFNC($P(PSD(2),U,2))
D:$P(DGPMA,U,2)=2
.N VAROOT,VAINDT S VAROOT="PSD",VAINDT=$P(DGPMA,U) D IN5^VADPT
.S $P(HLA("HLS",3),HL("FS"),7)=$P(PSD(15,4),U,2)_$E(HL("ECH"))_$E(HL("ECH"))
SEND S HLEID=EID D GENERATE^HLMA(HLEID,"LM",1,.HLRST,"",.HL) K PSD Q
EVN(EVENT,DATE) ;EVN Segment builder
S HLA("HLS",1)="EVN"_HL("FS")_"A0"_EVENT_HL("FS")_$$HLDATE^HLFNC(DATE) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDADT1 1798 printed Oct 16, 2024@17:45:50 Page 2
PSDADT1 ;BIR/LTL- ADT Admit Message builder for HL7 V 1.6; 24 Nov 95
+1 ;;3.0; CONTROLLED SUBSTANCES ;**30**;13 Feb 97
+2 ;Reference to ^HLCS(869.2 are covered by DBIA #1495
+3 ;Reference to ^ORD(101 are covered by DBIA #872
+4 ;Reference to $$EN^VAFHLPID are covered by DBIA #263
+5 ;
+6 if '$PIECE(DGPMA,U,2)!(("123")'[$PIECE(DGPMA,U,2))
QUIT
+7 if '$PIECE($GET(^HLCS(869.2,+$ORDER(^HLCS(869.2,"B","PSD-NDES HLLP",0)),200)),U)&('$PIECE($GET(^HLCS(869.2,+$ORDER(^HLCS(869.2,"B","PSD-NDES X3.28",0)),300)),U))
QUIT
+8 NEW HLMTN,HLEVN,HLFS,HLA,HL,HLQ,HLECH,PSDHL
SERVER SET EID=$ORDER(^ORD(101,"B",$SELECT($PIECE(DGPMA,U,2)=1:"PSD A01 SERVER",$PIECE(DGPMA,U,2)=2:"PSD A02 SERVER",1:"PSD A03 SERVER"),0))
SET INT=0
+1 DO INIT^HLFNC2(EID,.HL,INT)
+2 if $ORDER(HL(""))']""
QUIT
+3 DO EVN($PIECE(DGPMA,U,2),$PIECE(DGPMA,U))
+4 SET HLMTN="ADT"
SET HLEVN=1
SET HLFS=HL("FS")
SET HLECH=HL("ECH")
SET HLQ=""
PID SET HLA("HLS",2)=$$EN^VAFHLPID(DFN,"1,2,3,5")
+1 NEW PSDSTRN
+2 SET PSDSTRN=HLA("HLS",2)
SET $PIECE(PSDSTRN,HLFS,4)=$PIECE(HLA("HLS",2),HLFS,3)
+3 IF $LENGTH(PSDSTRN)>245
SET VAFPID(1)=$EXTRACT(PSDSTRN,246,999)_$GET(VAFPID(1))
+4 SET HLA("HLS",2)=$EXTRACT(PSDSTRN,1,245)
+5 ;
PV1 NEW VAROOT,VAINDT
SET VAROOT="PSD"
SET VAINDT=$PIECE(DGPMA,U)
DO INP^VADPT
+1 SET $PIECE(HLA("HLS",3),HL("FS"),3)="I"
+2 SET $PIECE(HLA("HLS",3),HL("FS"),8)=""
+3 SET $PIECE(HLA("HLS",3),HL("FS"))="PV1"
+4 SET $PIECE(HLA("HLS",3),HL("FS"),4)=$PIECE(PSD(4),U,2)_$EXTRACT(HL("ECH"))_$PIECE(PSD(5),"-")_$EXTRACT(HL("ECH"))_$PIECE(PSD(5),"-",2)
+5 SET $PIECE(HLA("HLS",3),HL("FS"),7)=$EXTRACT(HL("ECH"))_$EXTRACT(HL("ECH"))
+6 SET $PIECE(HLA("HLS",3),HL("FS"),8)=$PIECE(PSD(2),U)_$EXTRACT(HL("ECH"))_$$HLNAME^HLFNC($PIECE(PSD(2),U,2))
+7 if $PIECE(DGPMA,U,2)=2
Begin DoDot:1
+8 NEW VAROOT,VAINDT
SET VAROOT="PSD"
SET VAINDT=$PIECE(DGPMA,U)
DO IN5^VADPT
+9 SET $PIECE(HLA("HLS",3),HL("FS"),7)=$PIECE(PSD(15,4),U,2)_$EXTRACT(HL("ECH"))_$EXTRACT(HL("ECH"))
End DoDot:1
SEND SET HLEID=EID
DO GENERATE^HLMA(HLEID,"LM",1,.HLRST,"",.HL)
KILL PSD
QUIT
EVN(EVENT,DATE) ;EVN Segment builder
+1 SET HLA("HLS",1)="EVN"_HL("FS")_"A0"_EVENT_HL("FS")_$$HLDATE^HLFNC(DATE)
QUIT
