PSOHLDS4 ;BIR/PWC - Build HL7 Segments for Automated Interface ; 2/13/08 3:21pm
;;7.0;OUTPATIENT PHARMACY;**156,255,279,385,505,617**;DEC 1997;Build 110
;HLFNC supp. by DBIA 10106
;DIC(5 supp. by DBIA 10056
;EN^PSNPPIO supp. by DBIA 3794
;This routine is called from PSOHLDS1
;
;*255 moved tag NTEPMI from PSOHLDS2
Q
IAM(PSI) ;allergy list segment
Q:'$D(DFN)!$D(PAS3)
N IAM,IDX,SEV,SEV1,DAT,X,TYP,TYP1,VER,VER1
S IAM="",CNT=0,GMRA="0^0^111" D EN1^GMRADPT
I $G(GMRAL)="" G ZALQT
F AIEN=0:0 S AIEN=$O(GMRAL(AIEN)) Q:'AIEN D
.K ADTL D EN1^GMRAOR2(AIEN,"ADTL") S CNT=CNT+1
.S TYP1=$P(GMRAL(AIEN),"^",7)
.S TYP=$S(TYP1="D":"DRUG",TYP1="F":"FOOD",TYP1="O":"OTHER",TYP1="DF":"DRUG/FOOD",TYP1="DO":"DRUG/OTHER",TYP1="DFO":"DRUG/FOOD/OTHER",1:"""""")
.S VER=$S($P(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED")
.S VER1=$S($P(GMRAL(AIEN),"^",4)=1:"C",1:"U") ;confirmed or unconfirmed
.S $P(IAM,"|",2)=TYP1_CS_TYP_CS_"LGMR120.8"
.S $P(IAM,"|",3)=AIEN_CS_$P(GMRAL(AIEN),"^",2)_CS_"LGMR120.8"
.S IDX=$O(ADTL("O","")),X="" S:IDX'="" X=$G(ADTL("O",IDX))
.S DAT=$P(X,"^"),DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
.S SEV=$P(X,"^",2) S:SEV="" SEV="""""",DAT=""
.S SEV1=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U")
.S $P(IAM,"|",4)=SEV1
.S $P(IAM,"|",5)=$P($P(GMRAL(AIEN),"^",8),";")
.S $P(IAM,"|",13)=DAT
.S $P(IAM,"|",17)=VER1
.S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1
.F S IDX=$O(ADTL("O",IDX)) Q:IDX="" D ;repeat for all reactions
..S X=$G(ADTL("O",IDX)),DAT=$P(X,"^"),SEV=$P(X,"^",2) I SEV="" Q
..S DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
..S $P(IAM,FS,4)=SEV,$P(IAM,FS,13)=DAT
..S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1
S PAS3=1
;
ZALQT K GMRAL,ADTL,AIEN,CNT,CNT,GMRA,TYP,TYP1,SEV,SEV1,VER,VER1
Q
;
ORC(PSI) ;common order segment
Q:'$D(DFN)
N ORC S ORC=""
S $P(ORC,"|",1)="NW"
S $P(ORC,"|",2)=IRXN_CS_"OP7.0"
S $P(ORC,"|",9)=ISDT
S $P(ORC,"|",10)=EBY_CS_EBY1
S $P(ORC,"|",12)=PVDR_CS_PVDR1
S $P(ORC,"|",13)=$G(PSOLAP)
S $P(ORC,"|",15)=EFDT
S $P(ORC,"|",16)=$S($G(RXPR(IRXN)):"PARTIAL",$G(RXFL(IRXN)):"REFILL",$G(RXRP(IRXN)):"REPRINT",1:"NEW")
S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC"
S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"")
S $P(ORC,"|",20)=$S($$STATUS^PSOBPSUT(IRXN,$G(RXFL(IRXN)))]"":"VA5",1:"") ; Added ePharmacy indicator (VA5) BNT; PSO*7*385
S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)
S PSZIP=$P(SITE,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP
S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4)
;/BLB/ PSO*7.0*505 ;ADDED LOGIC TO ADD DIGITAL SIGNATURE FOR CONTROLLED SUBSTANCE PRESCRIPTIONS (eRx and CPRS)
I $$GET1^DIQ(52,IRXN,310,"I")!$$GET1^DIQ(52,IRXN,312,"I") S $P(ORC,"|",30)="EL"
S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1
Q
;
NTEPMI(PSI) ;build NTE segment for PMI sheets ;*255
Q:'$D(DFN) N A,I,PREVLN,CURRLN,PMI,PSNMSG,PSDRUG
S PSDRUG=+$P(^PSRX(IRXN,0),"^",6),PMI=$$EN^PSNPPIO(PSDRUG,.PSNMSG)
Q:'$D(^TMP($J,"PSNPMI"))
;PSO*7*279 Add missing PMI ID(7) to NTE Segment
S ^TMP("PSO",$J,PSI)="NTE"_FS_7_FS_FS_^TMP($J,"PSNPMI",0)
K A S CNT1=1,CNT=0
F A="W","U","H","S","M","P","I","O","N","D","R" S CNT=CNT+1,A(CNT)=A
F I=1:1:11 I $D(^TMP($J,"PSNPMI",A(I))) D
.S CNT=$P(^TMP($J,"PSNPMI",A(I),0),"^",3)
.S (PREVLN,CURRLN)=""
.F J=1:1:CNT D
.. S ^TMP("PSO",$J,PSI,CNT1)=^TMP($J,"PSNPMI",A(I),J,0)
.. ;PSO*198 check if " " should be inserted
.. S CURRLN=^TMP("PSO",$J,PSI,CNT1)
.. S:CNT1>1 PREVLN=$S(CNT>1:^TMP("PSO",$J,PSI,CNT1-1),1:"")
.. I CNT1>1,$$SPACE^PSOHLDS3(PREVLN,CURRLN) D
... S ^TMP("PSO",$J,PSI,CNT1)=" "_^TMP("PSO",$J,PSI,CNT1)
.. I J=1 S $P(^TMP("PSO",$J,PSI,CNT1),":",1)="\H\"_$P(^TMP("PSO",$J,PSI,CNT1),":",1)_"\N\"
.. S CNT1=CNT1+1
S ^TMP("PSO",$J,PSI,CNT1-1)=^TMP("PSO",$J,PSI,CNT1-1)_FS_"Patient Medication Instructions"
S PSI=PSI+1 K A,I,J,CNT,CNT1,^TMP($J,"PSNPMI")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDS4 4126 printed Sep 23, 2025@20:06:14 Page 2
PSOHLDS4 ;BIR/PWC - Build HL7 Segments for Automated Interface ; 2/13/08 3:21pm
+1 ;;7.0;OUTPATIENT PHARMACY;**156,255,279,385,505,617**;DEC 1997;Build 110
+2 ;HLFNC supp. by DBIA 10106
+3 ;DIC(5 supp. by DBIA 10056
+4 ;EN^PSNPPIO supp. by DBIA 3794
+5 ;This routine is called from PSOHLDS1
+6 ;
+7 ;*255 moved tag NTEPMI from PSOHLDS2
+8 QUIT
IAM(PSI) ;allergy list segment
+1 if '$DATA(DFN)!$DATA(PAS3)
QUIT
+2 NEW IAM,IDX,SEV,SEV1,DAT,X,TYP,TYP1,VER,VER1
+3 SET IAM=""
SET CNT=0
SET GMRA="0^0^111"
DO EN1^GMRADPT
+4 IF $GET(GMRAL)=""
GOTO ZALQT
+5 FOR AIEN=0:0
SET AIEN=$ORDER(GMRAL(AIEN))
if 'AIEN
QUIT
Begin DoDot:1
+6 KILL ADTL
DO EN1^GMRAOR2(AIEN,"ADTL")
SET CNT=CNT+1
+7 SET TYP1=$PIECE(GMRAL(AIEN),"^",7)
+8 SET TYP=$SELECT(TYP1="D":"DRUG",TYP1="F":"FOOD",TYP1="O":"OTHER",TYP1="DF":"DRUG/FOOD",TYP1="DO":"DRUG/OTHER",TYP1="DFO":"DRUG/FOOD/OTHER",1:"""""")
+9 SET VER=$SELECT($PIECE(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED")
+10 ;confirmed or unconfirmed
SET VER1=$SELECT($PIECE(GMRAL(AIEN),"^",4)=1:"C",1:"U")
+11 SET $PIECE(IAM,"|",2)=TYP1_CS_TYP_CS_"LGMR120.8"
+12 SET $PIECE(IAM,"|",3)=AIEN_CS_$PIECE(GMRAL(AIEN),"^",2)_CS_"LGMR120.8"
+13 SET IDX=$ORDER(ADTL("O",""))
SET X=""
if IDX'=""
SET X=$GET(ADTL("O",IDX))
+14 SET DAT=$PIECE(X,"^")
SET DAT=$SELECT(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
+15 SET SEV=$PIECE(X,"^",2)
if SEV=""
SET SEV=""""""
SET DAT=""
+16 SET SEV1=$SELECT(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U")
+17 SET $PIECE(IAM,"|",4)=SEV1
+18 SET $PIECE(IAM,"|",5)=$PIECE($PIECE(GMRAL(AIEN),"^",8),";")
+19 SET $PIECE(IAM,"|",13)=DAT
+20 SET $PIECE(IAM,"|",17)=VER1
+21 SET ^TMP("PSO",$JOB,PSI)="IAM|"_IAM
SET PSI=PSI+1
+22 ;repeat for all reactions
FOR
SET IDX=$ORDER(ADTL("O",IDX))
if IDX=""
QUIT
Begin DoDot:2
+23 SET X=$GET(ADTL("O",IDX))
SET DAT=$PIECE(X,"^")
SET SEV=$PIECE(X,"^",2)
IF SEV=""
QUIT
+24 SET DAT=$SELECT(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
+25 SET $PIECE(IAM,FS,4)=SEV
SET $PIECE(IAM,FS,13)=DAT
+26 SET ^TMP("PSO",$JOB,PSI)="IAM|"_IAM
SET PSI=PSI+1
End DoDot:2
End DoDot:1
+27 SET PAS3=1
+28 ;
ZALQT KILL GMRAL,ADTL,AIEN,CNT,CNT,GMRA,TYP,TYP1,SEV,SEV1,VER,VER1
+1 QUIT
+2 ;
ORC(PSI) ;common order segment
+1 if '$DATA(DFN)
QUIT
+2 NEW ORC
SET ORC=""
+3 SET $PIECE(ORC,"|",1)="NW"
+4 SET $PIECE(ORC,"|",2)=IRXN_CS_"OP7.0"
+5 SET $PIECE(ORC,"|",9)=ISDT
+6 SET $PIECE(ORC,"|",10)=EBY_CS_EBY1
+7 SET $PIECE(ORC,"|",12)=PVDR_CS_PVDR1
+8 SET $PIECE(ORC,"|",13)=$GET(PSOLAP)
+9 SET $PIECE(ORC,"|",15)=EFDT
+10 SET $PIECE(ORC,"|",16)=$SELECT($GET(RXPR(IRXN)):"PARTIAL",$GET(RXFL(IRXN)):"REFILL",$GET(RXRP(IRXN)):"REPRINT",1:"NEW")
+11 SET $PIECE(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC"
+12 SET $PIECE(ORC,"|",19)=$SELECT(CSINER'="":CSINER_CS_CSINER1,1:"")
+13 ; Added ePharmacy indicator (VA5) BNT; PSO*7*385
SET $PIECE(ORC,"|",20)=$SELECT($$STATUS^PSOBPSUT(IRXN,$GET(RXFL(IRXN)))]"":"VA5",1:"")
+14 SET $PIECE(ORC,"|",21)=$PIECE(SITE,"^",1)_CS_CS_$PIECE(SITE,"^",6)
+15 SET PSZIP=$PIECE(SITE,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+16 SET $PIECE(ORC,"|",22)=$PIECE(SITE,"^",2)_CS_CS_$PIECE(SITE,"^",7)_CS_$SELECT($DATA(^DIC(5,+$PIECE(SITE,"^",8),0)):$PIECE(^(0),"^",2),1:"UKN")_CS_PSOHZIP
+17 SET $PIECE(ORC,"|",23)="("_$PIECE(SITE,"^",3)_")"_$PIECE(SITE,"^",4)
+18 ;/BLB/ PSO*7.0*505 ;ADDED LOGIC TO ADD DIGITAL SIGNATURE FOR CONTROLLED SUBSTANCE PRESCRIPTIONS (eRx and CPRS)
+19 IF $$GET1^DIQ(52,IRXN,310,"I")!$$GET1^DIQ(52,IRXN,312,"I")
SET $PIECE(ORC,"|",30)="EL"
+20 SET ^TMP("PSO",$JOB,PSI)="ORC|"_ORC
SET PSI=PSI+1
+21 QUIT
+22 ;
NTEPMI(PSI) ;build NTE segment for PMI sheets ;*255
+1 if '$DATA(DFN)
QUIT
NEW A,I,PREVLN,CURRLN,PMI,PSNMSG,PSDRUG
+2 SET PSDRUG=+$PIECE(^PSRX(IRXN,0),"^",6)
SET PMI=$$EN^PSNPPIO(PSDRUG,.PSNMSG)
+3 if '$DATA(^TMP($JOB,"PSNPMI"))
QUIT
+4 ;PSO*7*279 Add missing PMI ID(7) to NTE Segment
+5 SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_7_FS_FS_^TMP($JOB,"PSNPMI",0)
+6 KILL A
SET CNT1=1
SET CNT=0
+7 FOR A="W","U","H","S","M","P","I","O","N","D","R"
SET CNT=CNT+1
SET A(CNT)=A
+8 FOR I=1:1:11
IF $DATA(^TMP($JOB,"PSNPMI",A(I)))
Begin DoDot:1
+9 SET CNT=$PIECE(^TMP($JOB,"PSNPMI",A(I),0),"^",3)
+10 SET (PREVLN,CURRLN)=""
+11 FOR J=1:1:CNT
Begin DoDot:2
+12 SET ^TMP("PSO",$JOB,PSI,CNT1)=^TMP($JOB,"PSNPMI",A(I),J,0)
+13 ;PSO*198 check if " " should be inserted
+14 SET CURRLN=^TMP("PSO",$JOB,PSI,CNT1)
+15 if CNT1>1
SET PREVLN=$SELECT(CNT>1:^TMP("PSO",$JOB,PSI,CNT1-1),1:"")
+16 IF CNT1>1
IF $$SPACE^PSOHLDS3(PREVLN,CURRLN)
Begin DoDot:3
+17 SET ^TMP("PSO",$JOB,PSI,CNT1)=" "_^TMP("PSO",$JOB,PSI,CNT1)
End DoDot:3
+18 IF J=1
SET $PIECE(^TMP("PSO",$JOB,PSI,CNT1),":",1)="\H\"_$PIECE(^TMP("PSO",$JOB,PSI,CNT1),":",1)_"\N\"
+19 SET CNT1=CNT1+1
End DoDot:2
End DoDot:1
+20 SET ^TMP("PSO",$JOB,PSI,CNT1-1)=^TMP("PSO",$JOB,PSI,CNT1-1)_FS_"Patient Medication Instructions"
+21 SET PSI=PSI+1
KILL A,I,J,CNT,CNT1,^TMP($JOB,"PSNPMI")
+22 QUIT
