- 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
- 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
