PSDADT1.m

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

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