PSOHLSG2 ;BIR/LC-Build HL7 Segments ;03/01/96 09:45
;;7.0;OUTPATIENT PHARMACY;**30,139,162,172**;DEC 1997
;External reference to DIWP supported by DBIA 10011
;External reference to HLFNC supported by DBIA 10106
;External reference to ^PS(51 supported by DBIA 2224
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(54 supported by DBIA 2227
;External reference to EN1^GMRAOR2 supported by DBIA 2422
;External reference to ^DPT supported by DBIA 3097
;External reference to EN1^GMRADPT supported by DBIA 10099
;Cont'd build HL7 segments
;
ZAL(PSI) ;allergy list segment
Q:'$D(DFN)
N ZAL,IDX,SEV,DAT,X
S 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 ZAL="ZAL"_FS_AIEN_FS_$P(GMRAL(AIEN),"^",2)_FS_$P($P(GMRAL(AIEN),"^",6),";")
.S ZAL=ZAL_FS_$S($P(GMRAL(AIEN),"^",3)="D":"DRUG",$P(GMRAL(AIEN),"^",3)="F":"FOOD",$P(GMRAL(AIEN),"^",3)="O":"OTHER",1:"""""")
.S ZAL=ZAL_FS_$S($P(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED")
.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 $P(ZAL,FS,7,8)=SEV_FS_DAT,^TMP("PSO",$J,PSI)=ZAL,PSI=PSI+1
.F S IDX=$O(ADTL("O",IDX)) Q:IDX="" D
..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(ZAL,FS,7,8)=SEV_FS_DAT,^TMP("PSO",$J,PSI)=ZAL,PSI=PSI+1
;
ZALQT K GMRAL,ADTL,AIEN,CNT,CNT,GMRA
Q
;
ZML(PSI) ;multi-Rx label segment
Q:'$D(DFN)
N ZML S CNT1=0
I '$D(PSSPND),$P(PSOPAR,"^",18) D
.F PSRX=0:0 S PSRX=$O(^PS(55,DFN,"P",PSRX)) Q:'PSRX D
..S PSRXX=+^PS(55,DFN,"P",PSRX,0) I $D(^PSRX(PSRXX,0)) S PSRFL=$P(^(0),"^",9) D:$D(^(1))&PSRFL
...F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC S PSRFL=PSRFL-1
...I $G(PSRFL)>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0
..I $G(PSRFL)>0,$P($G(^PSRX(PSRXX,"STA")),"^")<10,$P(^(2),"^",6)>DT S RX(PSRXX)=$P(^(2),"^",6)_"^"_PSRFL Q
.S PSA=0 F J=1:1 S PSA=$O(RX(PSA)) Q:'PSA D
..S DRG=$$ZZ^PSOSUTL(PSA),CNT1=CNT1+1 K ZDRUG
..S REFILLS=$P(RX(PSA),"^",2),EXPDATE=$P(RX(PSA),"^"),EXPDATE=$$HLDATE^HLFNC(EXPDATE,"DT")
..S RXNUM=$P(^PSRX(PSA,0),"^")
..I $G(PSOBARS),$P($G(PSOPAR),"^",19) S BARCODE=PSOINST_"-"_PSA
..S ZML="ZML"_FS_DRG_FS_REFILLS_FS_EXPDATE_FS_RXNUM_FS_$S($G(BARCODE):BARCODE,1:"""""")
..S ^TMP("PSO",$J,PSI)=ZML
..S PSI=PSI+1
K PSRX,PSRXX,PSRFL,AMC,J,X,X1,X2,RX,PSA,DRG,CNT1,REFILLS,EXPDATE,RXNUM,BARCODE
Q
;
ZSL(PSI) ;build Suspense Notice segment
Q:'$D(DFN)
N ZSL
S (PSSUFLG,PSSPCNT)=0 S PSODFN=DFN,(SPPL,RXX,STA)=""
I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
D ^PSOBUILD S (STA,RXX)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S RXX=$O(PSOSD(STA,RXX)) Q:RXX="" I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL
F XX=1:1 Q:$P(SPPL,",",XX)="" S PSSSRX=$P(SPPL,",",XX) D
.S SPNUM=$O(^PS(52.5,"B",PSSSRX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S SPDATE=$$HLDATE^HLFNC(SPDATE,"DT")
.S $P(PSOLGTH," ",(20-($L($P(^PSRX(PSSSRX,0),"^")))))=""
.S ZSL="ZSL"_FS_$$ZZ^PSOSUTL(PSSSRX)_FS_$G(SPDATE)_FS_$P(^PSRX(PSSSRX,0),"^")
.S ^TMP("PSO",$J,PSI)=ZSL
.S PSI=PSI+1
K SPNUM,SPDATE,PSSUFLG,PSSPCNT,SPPL,RXX,STA,X1,X2,XX,X,PSOSD,PSSSRX,PSOLGTH,PSODTCUT
Q
;
NTE1(PSI) ;build NTE segment for SIG
;
Q:'$D(DFN)
N NTE1
S SIG=$P($G(^PSRX(IRXN,"SIG")),"^") I $P($G(^PSRX(IRXN,"SIG")),"^",2) D PSOLBL3,SIGOLD
I '$P($G(^PSRX(IRXN,"SIG")),"^",2) D SIG
S NTE1="NTE"_FS_1_FS_FS,FLD3="" F DR=1:1 Q:$G(SGY(DR))="" S FLD3=FLD3_SGY(DR)
S ^TMP("PSO",$J,PSI)=NTE1_FLD3
S PSI=PSI+1
K SIG,E,F,S,FLD3,X,Y,SGY,SGC,Z,DR,%,J,P
Q
;
SIG S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D:X]""
.I $D(^PS(51,"A",X)) S %=^(X),X=$P(%,"^") I $P(%,"^",2)]"" S Y=$P(SIG," ",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(%,"^",2)
.S SGY=SGY_X_" "
S X="",SGC=1 F J=1:1 S Z=$P(SGY," ",J) S:Z="" SGY(SGC)=X Q:Z="" S:$L(X)+$L(Z)'<$S($P(PSOPAR,"^",28):46,1:34) SGY(SGC)=X,SGC=SGC+1,X="" S X=X_Z_" "
SIGOLD I '$P(PSOPAR,"^",28) I $P($G(^DPT(DFN,"NHC")),"^")="Y"!($P($G(^PS(55,DFN,40)),"^")) S SGC=SGC+1,SGY(SGC)="Expiration:________ Mfg:_________"
I $P(PSOPAR,"^",28) K SIG,E,F,S
Q
;
PSOLBL3 ;RX must be defined (Internal), Check already done for OERR SIG
;Format OERR Sig for New and Old label stock
N CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,ZZZZ,PSLONG,PPPP
S PSLONG=$S($P(PSOPAR,"^",28):46,1:34),RX=IRXN
; NEXT LINE IF SIG IS MOVED BACK TO MULTIPLE
S PPPP=1 F PPP=0:0 S PPP=$O(^PSRX(RX,"SIG1",PPP)) Q:'PPP I $G(^PSRX(RX,"SIG1",PPP,0))'="" S SIG9(PPPP)=^(0) S PPPP=PPPP+1
;NEXT LINE IF 1ST FRONT DOOR SIG LINE LIVES IN BACK DOOR SPOT
;S SIG9(1)=$P($G(^PSRX(RX,"SIG")),"^") S PPP=2 F PPPP=0:0 S PPPP=$O(^PSRX(RX,"SIG1",PPPP)) Q:'PPPP I $G(^(PPPP,0))'="" S SIG9(PPP)=$G(^(0)),PPP=PPP+1
S (LVAR,LVAR1)="",LLLL=1
F FFFF=0:0 S FFFF=$O(SIG9(FFFF)) Q:'FFFF S SGCT=0 F ZZZZ=1:1:$L(SIG9(FFFF)) I $E(SIG9(FFFF),ZZZZ)=" "!($L(SIG9(FFFF))=ZZZZ) S SGCT=SGCT+1 D I $L(LVAR)>PSLONG S SGY(LLLL)=LLIM_" ",LLLL=LLLL+1,LVAR=LVAR1
.S LVAR1=$P(SIG9(FFFF)," ",(SGCT))
.S LLIM=LVAR
.S LVAR=$S(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
I $G(LVAR)'="" S SGY(LLLL)=LVAR
I '$P(PSOPAR,"^",28) S SGC=0 F CTCT=0:0 S CTCT=$O(SGY(CTCT)) Q:'CTCT S SGC=SGC+1
Q
NTE2(PSI) ;build NTE segment for patient narrative
Q:'$D(DFN)
N NTE2
K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
S NTE2="NTE"_FS_2_FS_FS,^TMP("PSO",$J,PSI)=NTE2
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP("PSO",$J,PSI,PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1
I PSSIXFL S ^TMP("PSO",$J,PSI,PSNACNT)=" " S PSNACNT=PSNACNT+1
S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP("PSO",$J,PSI,PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1
I PSSEVFL S ^TMP("PSO",$J,PSI,PSNACNT)=" " S PSNACNT=PSNACNT+1
S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP("PSO",$J,PSI,PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1
F LLL=1:1:PSNACNT-1 I $L(^TMP("PSO",$J,PSI,LLL))=0 S ^TMP("PSO",$J,PSI,LLL)=" "
S:$D(NTE2) PSI=PSI+1
K DIWF,DIWL,DIWR,LLL,PSNACNT,PSSEVFL,PSSIXFL,ZZ
Q
NTE3(PSI) ;build NTE segment for drug warning narrative
Q:'$D(DFN)
N NTE3
S WARN=$P($G(^PSDRUG(IDGN,0)),"^",8)
S:$D(WARN) NTE3="NTE"_FS_3_FS_FS,^TMP("PSO",$J,PSI)=NTE3,CNT=1
F WWW=1:1 Q:$P(WARN,",",WWW,99)="" S PSOWARN=$P(WARN,",",WWW) D:$D(^PS(54,PSOWARN,0))
. S JJJ=0
. F S JJJ=$O(^PS(54,PSOWARN,1,JJJ)) Q:'JJJ D
. . I $D(^PS(54,PSOWARN,1,JJJ,0)) S ^TMP("PSO",$J,PSI,CNT)=^PS(54,PSOWARN,1,JJJ,0),CNT=CNT+1
. . Q
. Q
S:$D(NTE3) PSI=PSI+1
K WARN,CNT,WW,JJJ,PSOWARN,RX,WWW
Q
;
NTE4(PSI) ;build NTE segment for profile information
Q:'$D(DFN) S PSODFN=DFN
N NTE4
I $P(PSOPAR,"^",8) D START^PSOHLSG3
S:$D(NTE4) PSI=PSI+1
Q
NTE5(PSI) ;build NTE segment for drug interactions
Q:'$D(DFN)
N NTE5
D:$D(DRI) START2^PSOHLSG3
S:$D(NTE5) ^TMP("PSO",$J,PSI)=NTE5
S:'$D(NTE5) ^TMP("PSO",$J,PSI)="NTE"_FS_5_FS_FS
S PSI=PSI+1
Q
NTE6(PSI) ;build NTE segment for drug allergy indications
Q:'$D(DFN)
N NTE6
D:$D(DAW) START3^PSOHLSG3
S ^TMP("PSO",$J,PSI)=NTE6
S PSI=PSI+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLSG2 7759 printed Apr 09, 2024@21:35:21 Page 2
PSOHLSG2 ;BIR/LC-Build HL7 Segments ;03/01/96 09:45
+1 ;;7.0;OUTPATIENT PHARMACY;**30,139,162,172**;DEC 1997
+2 ;External reference to DIWP supported by DBIA 10011
+3 ;External reference to HLFNC supported by DBIA 10106
+4 ;External reference to ^PS(51 supported by DBIA 2224
+5 ;External reference to ^PS(55 supported by DBIA 2228
+6 ;External reference to ^PSDRUG supported by DBIA 221
+7 ;External reference to ^PS(54 supported by DBIA 2227
+8 ;External reference to EN1^GMRAOR2 supported by DBIA 2422
+9 ;External reference to ^DPT supported by DBIA 3097
+10 ;External reference to EN1^GMRADPT supported by DBIA 10099
+11 ;Cont'd build HL7 segments
+12 ;
ZAL(PSI) ;allergy list segment
+1 if '$DATA(DFN)
QUIT
+2 NEW ZAL,IDX,SEV,DAT,X
+3 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 ZAL="ZAL"_FS_AIEN_FS_$PIECE(GMRAL(AIEN),"^",2)_FS_$PIECE($PIECE(GMRAL(AIEN),"^",6),";")
+8 SET ZAL=ZAL_FS_$SELECT($PIECE(GMRAL(AIEN),"^",3)="D":"DRUG",$PIECE(GMRAL(AIEN),"^",3)="F":"FOOD",$PIECE(GMRAL(AIEN),"^",3)="O":"OTHER",1:"""""")
+9 SET ZAL=ZAL_FS_$SELECT($PIECE(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED")
+10 SET IDX=$ORDER(ADTL("O",""))
SET X=""
if IDX'=""
SET X=$GET(ADTL("O",IDX))
+11 SET DAT=$PIECE(X,"^")
SET DAT=$SELECT(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
+12 SET SEV=$PIECE(X,"^",2)
if SEV=""
SET SEV=""""""
SET DAT=""
+13 SET $PIECE(ZAL,FS,7,8)=SEV_FS_DAT
SET ^TMP("PSO",$JOB,PSI)=ZAL
SET PSI=PSI+1
+14 FOR
SET IDX=$ORDER(ADTL("O",IDX))
if IDX=""
QUIT
Begin DoDot:2
+15 SET X=$GET(ADTL("O",IDX))
SET DAT=$PIECE(X,"^")
SET SEV=$PIECE(X,"^",2)
IF SEV=""
QUIT
+16 SET DAT=$SELECT(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
+17 SET $PIECE(ZAL,FS,7,8)=SEV_FS_DAT
SET ^TMP("PSO",$JOB,PSI)=ZAL
SET PSI=PSI+1
End DoDot:2
End DoDot:1
+18 ;
ZALQT KILL GMRAL,ADTL,AIEN,CNT,CNT,GMRA
+1 QUIT
+2 ;
ZML(PSI) ;multi-Rx label segment
+1 if '$DATA(DFN)
QUIT
+2 NEW ZML
SET CNT1=0
+3 IF '$DATA(PSSPND)
IF $PIECE(PSOPAR,"^",18)
Begin DoDot:1
+4 FOR PSRX=0:0
SET PSRX=$ORDER(^PS(55,DFN,"P",PSRX))
if 'PSRX
QUIT
Begin DoDot:2
+5 SET PSRXX=+^PS(55,DFN,"P",PSRX,0)
IF $DATA(^PSRX(PSRXX,0))
SET PSRFL=$PIECE(^(0),"^",9)
if $DATA(^(1))&PSRFL
Begin DoDot:3
+6 FOR AMC=0:0
SET AMC=$ORDER(^PSRX(PSRXX,1,AMC))
if 'AMC
QUIT
SET PSRFL=PSRFL-1
+7 IF $GET(PSRFL)>0
SET X1=DT
SET X2=$PIECE(^PSRX(PSRXX,0),"^",8)-10
DO C^%DTC
IF X'<$PIECE(^(2),"^",6)
SET PSRFL=0
End DoDot:3
+8 IF $GET(PSRFL)>0
IF $PIECE($GET(^PSRX(PSRXX,"STA")),"^")<10
IF $PIECE(^(2),"^",6)>DT
SET RX(PSRXX)=$PIECE(^(2),"^",6)_"^"_PSRFL
QUIT
End DoDot:2
+9 SET PSA=0
FOR J=1:1
SET PSA=$ORDER(RX(PSA))
if 'PSA
QUIT
Begin DoDot:2
+10 SET DRG=$$ZZ^PSOSUTL(PSA)
SET CNT1=CNT1+1
KILL ZDRUG
+11 SET REFILLS=$PIECE(RX(PSA),"^",2)
SET EXPDATE=$PIECE(RX(PSA),"^")
SET EXPDATE=$$HLDATE^HLFNC(EXPDATE,"DT")
+12 SET RXNUM=$PIECE(^PSRX(PSA,0),"^")
+13 IF $GET(PSOBARS)
IF $PIECE($GET(PSOPAR),"^",19)
SET BARCODE=PSOINST_"-"_PSA
+14 SET ZML="ZML"_FS_DRG_FS_REFILLS_FS_EXPDATE_FS_RXNUM_FS_$SELECT($GET(BARCODE):BARCODE,1:"""""")
+15 SET ^TMP("PSO",$JOB,PSI)=ZML
+16 SET PSI=PSI+1
End DoDot:2
End DoDot:1
+17 KILL PSRX,PSRXX,PSRFL,AMC,J,X,X1,X2,RX,PSA,DRG,CNT1,REFILLS,EXPDATE,RXNUM,BARCODE
+18 QUIT
+19 ;
ZSL(PSI) ;build Suspense Notice segment
+1 if '$DATA(DFN)
QUIT
+2 NEW ZSL
+3 SET (PSSUFLG,PSSPCNT)=0
SET PSODFN=DFN
SET (SPPL,RXX,STA)=""
+4 IF $GET(PSODTCUT)']""
SET X1=DT
SET X2=-120
DO C^%DTC
SET PSODTCUT=X
+5 DO ^PSOBUILD
SET (STA,RXX)=""
FOR
SET STA=$ORDER(PSOSD(STA))
if STA=""
QUIT
FOR
SET RXX=$ORDER(PSOSD(STA,RXX))
if RXX=""
QUIT
IF $PIECE(PSOSD(STA,RXX),"^",2)=5
SET SPPL=$PIECE(PSOSD(STA,RXX),"^")_","_SPPL
+6 FOR XX=1:1
if $PIECE(SPPL,",",XX)=""
QUIT
SET PSSSRX=$PIECE(SPPL,",",XX)
Begin DoDot:1
+7 SET SPNUM=$ORDER(^PS(52.5,"B",PSSSRX,0))
IF SPNUM
SET SPDATE=$PIECE($GET(^PS(52.5,SPNUM,0)),"^",2)
SET SPDATE=$$HLDATE^HLFNC(SPDATE,"DT")
+8 SET $PIECE(PSOLGTH," ",(20-($LENGTH($PIECE(^PSRX(PSSSRX,0),"^")))))=""
+9 SET ZSL="ZSL"_FS_$$ZZ^PSOSUTL(PSSSRX)_FS_$GET(SPDATE)_FS_$PIECE(^PSRX(PSSSRX,0),"^")
+10 SET ^TMP("PSO",$JOB,PSI)=ZSL
+11 SET PSI=PSI+1
End DoDot:1
+12 KILL SPNUM,SPDATE,PSSUFLG,PSSPCNT,SPPL,RXX,STA,X1,X2,XX,X,PSOSD,PSSSRX,PSOLGTH,PSODTCUT
+13 QUIT
+14 ;
NTE1(PSI) ;build NTE segment for SIG
+1 ;
+2 if '$DATA(DFN)
QUIT
+3 NEW NTE1
+4 SET SIG=$PIECE($GET(^PSRX(IRXN,"SIG")),"^")
IF $PIECE($GET(^PSRX(IRXN,"SIG")),"^",2)
DO PSOLBL3
DO SIGOLD
+5 IF '$PIECE($GET(^PSRX(IRXN,"SIG")),"^",2)
DO SIG
+6 SET NTE1="NTE"_FS_1_FS_FS
SET FLD3=""
FOR DR=1:1
if $GET(SGY(DR))=""
QUIT
SET FLD3=FLD3_SGY(DR)
+7 SET ^TMP("PSO",$JOB,PSI)=NTE1_FLD3
+8 SET PSI=PSI+1
+9 KILL SIG,E,F,S,FLD3,X,Y,SGY,SGC,Z,DR,%,J,P
+10 QUIT
+11 ;
SIG SET SGY=""
FOR P=1:1:$LENGTH(SIG," ")
SET X=$PIECE(SIG," ",P)
if X]""
Begin DoDot:1
+1 IF $DATA(^PS(51,"A",X))
SET %=^(X)
SET X=$PIECE(%,"^")
IF $PIECE(%,"^",2)]""
SET Y=$PIECE(SIG," ",P-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
if Y>1
SET X=$PIECE(%,"^",2)
+2 SET SGY=SGY_X_" "
End DoDot:1
+3 SET X=""
SET SGC=1
FOR J=1:1
SET Z=$PIECE(SGY," ",J)
if Z=""
SET SGY(SGC)=X
if Z=""
QUIT
if $LENGTH(X)+$LENGTH(Z)'<$SELECT($PIECE(PSOPAR,"^",28)
SET SGY(SGC)=X
SET SGC=SGC+1
SET X=""
SET X=X_Z_" "
SIGOLD IF '$PIECE(PSOPAR,"^",28)
IF $PIECE($GET(^DPT(DFN,"NHC")),"^")="Y"!($PIECE($GET(^PS(55,DFN,40)),"^"))
SET SGC=SGC+1
SET SGY(SGC)="Expiration:________ Mfg:_________"
+1 IF $PIECE(PSOPAR,"^",28)
KILL SIG,E,F,S
+2 QUIT
+3 ;
PSOLBL3 ;RX must be defined (Internal), Check already done for OERR SIG
+1 ;Format OERR Sig for New and Old label stock
+2 NEW CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,ZZZZ,PSLONG,PPPP
+3 SET PSLONG=$SELECT($PIECE(PSOPAR,"^",28):46,1:34)
SET RX=IRXN
+4 ; NEXT LINE IF SIG IS MOVED BACK TO MULTIPLE
+5 SET PPPP=1
FOR PPP=0:0
SET PPP=$ORDER(^PSRX(RX,"SIG1",PPP))
if 'PPP
QUIT
IF $GET(^PSRX(RX,"SIG1",PPP,0))'=""
SET SIG9(PPPP)=^(0)
SET PPPP=PPPP+1
+6 ;NEXT LINE IF 1ST FRONT DOOR SIG LINE LIVES IN BACK DOOR SPOT
+7 ;S SIG9(1)=$P($G(^PSRX(RX,"SIG")),"^") S PPP=2 F PPPP=0:0 S PPPP=$O(^PSRX(RX,"SIG1",PPPP)) Q:'PPPP I $G(^(PPPP,0))'="" S SIG9(PPP)=$G(^(0)),PPP=PPP+1
+8 SET (LVAR,LVAR1)=""
SET LLLL=1
+9 FOR FFFF=0:0
SET FFFF=$ORDER(SIG9(FFFF))
if 'FFFF
QUIT
SET SGCT=0
FOR ZZZZ=1:1:$LENGTH(SIG9(FFFF))
IF $EXTRACT(SIG9(FFFF),ZZZZ)=" "!($LENGTH(SIG9(FFFF))=ZZZZ)
SET SGCT=SGCT+1
Begin DoDot:1
+10 SET LVAR1=$PIECE(SIG9(FFFF)," ",(SGCT))
+11 SET LLIM=LVAR
+12 SET LVAR=$SELECT(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
End DoDot:1
IF $LENGTH(LVAR)>PSLONG
SET SGY(LLLL)=LLIM_" "
SET LLLL=LLLL+1
SET LVAR=LVAR1
+13 IF $GET(LVAR)'=""
SET SGY(LLLL)=LVAR
+14 IF '$PIECE(PSOPAR,"^",28)
SET SGC=0
FOR CTCT=0:0
SET CTCT=$ORDER(SGY(CTCT))
if 'CTCT
QUIT
SET SGC=SGC+1
+15 QUIT
NTE2(PSI) ;build NTE segment for patient narrative
+1 if '$DATA(DFN)
QUIT
+2 NEW NTE2
+3 KILL ^UTILITY($JOB,"W")
SET (DIWL,PSNACNT)=1
SET DIWR=45
SET DIWF=""
SET (PSSIXFL,PSSEVFL)=0
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,6,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+4 SET NTE2="NTE"_FS_2_FS_FS
SET ^TMP("PSO",$JOB,PSI)=NTE2
+5 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
SET PSSIXFL=1
+6 IF PSSIXFL
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=" "
SET PSNACNT=PSNACNT+1
+7 SET DIWL=1
SET DIWR=45
SET DIWF=""
KILL ^UTILITY($JOB,"W")
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,7,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+8 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
SET PSSEVFL=1
+9 IF PSSEVFL
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=" "
SET PSNACNT=PSNACNT+1
+10 SET DIWL=1
SET DIWR=45
SET DIWF=""
KILL ^UTILITY($JOB,"W")
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,4,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+11 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
+12 FOR LLL=1:1:PSNACNT-1
IF $LENGTH(^TMP("PSO",$JOB,PSI,LLL))=0
SET ^TMP("PSO",$JOB,PSI,LLL)=" "
+13 if $DATA(NTE2)
SET PSI=PSI+1
+14 KILL DIWF,DIWL,DIWR,LLL,PSNACNT,PSSEVFL,PSSIXFL,ZZ
+15 QUIT
NTE3(PSI) ;build NTE segment for drug warning narrative
+1 if '$DATA(DFN)
QUIT
+2 NEW NTE3
+3 SET WARN=$PIECE($GET(^PSDRUG(IDGN,0)),"^",8)
+4 if $DATA(WARN)
SET NTE3="NTE"_FS_3_FS_FS
SET ^TMP("PSO",$JOB,PSI)=NTE3
SET CNT=1
+5 FOR WWW=1:1
if $PIECE(WARN,",",WWW,99)=""
QUIT
SET PSOWARN=$PIECE(WARN,",",WWW)
if $DATA(^PS(54,PSOWARN,0))
Begin DoDot:1
+6 SET JJJ=0
+7 FOR
SET JJJ=$ORDER(^PS(54,PSOWARN,1,JJJ))
if 'JJJ
QUIT
Begin DoDot:2
+8 IF $DATA(^PS(54,PSOWARN,1,JJJ,0))
SET ^TMP("PSO",$JOB,PSI,CNT)=^PS(54,PSOWARN,1,JJJ,0)
SET CNT=CNT+1
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 if $DATA(NTE3)
SET PSI=PSI+1
+12 KILL WARN,CNT,WW,JJJ,PSOWARN,RX,WWW
+13 QUIT
+14 ;
NTE4(PSI) ;build NTE segment for profile information
+1 if '$DATA(DFN)
QUIT
SET PSODFN=DFN
+2 NEW NTE4
+3 IF $PIECE(PSOPAR,"^",8)
DO START^PSOHLSG3
+4 if $DATA(NTE4)
SET PSI=PSI+1
+5 QUIT
NTE5(PSI) ;build NTE segment for drug interactions
+1 if '$DATA(DFN)
QUIT
+2 NEW NTE5
+3 if $DATA(DRI)
DO START2^PSOHLSG3
+4 if $DATA(NTE5)
SET ^TMP("PSO",$JOB,PSI)=NTE5
+5 if '$DATA(NTE5)
SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_5_FS_FS
+6 SET PSI=PSI+1
+7 QUIT
NTE6(PSI) ;build NTE segment for drug allergy indications
+1 if '$DATA(DFN)
QUIT
+2 NEW NTE6
+3 if $DATA(DAW)
DO START3^PSOHLSG3
+4 SET ^TMP("PSO",$JOB,PSI)=NTE6
+5 SET PSI=PSI+1
+6 QUIT
