source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSG2.m@ 636

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