PSOLBL3 ;BHAM ISC/RTR-Label utility routine ;29-May-2012 14:51;PLS
;;7.0;OUTPATIENT PHARMACY;**117,1009,1015**;DEC 1997;Build 62
;External reference ^PS(55 supported by DBIA 2228
;
;RX must be defined (Internal), Check already done for OERR SIG
;Format OERR Sig for New and Old label stock
; Modified - IHS/CIA/PLS - 02/02/04 - PSOLBL3+9 and OTHL+1
; IHS/MSC/PLS - 07/29/10 - PSOLBL3+12 and OTHL+1
N CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,OSIG,ZZZZ,PSLONG,PPPP
I $P($G(^PS(55,DFN,"LAN")),"^") D OTHL G:$G(FND) FMSIG
;IHS/CIA/PLS - 02/02/04 - Use IHS Site parameter for wrap width
;S PSLONG=$S($P(PSOPAR,"^",28):46,1:34)
;IHS/MSC/PLS - 07/29/2010 - Fix for undefined %APSITE when tasked
S PSLONG=$S($P(PSOPAR,"^",28):46,$$GET1^DIQ(9009033,PSOSITE,3):$$GET1^DIQ(9009033,PSOSITE,3),1:34) ;1:$P(%APSITE,U,4))
; 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
FMSIG 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
I $O(OSGY(0)) D
.F I=0:0 S I=$O(SGY(I)) Q:'I I $G(OSGY(I))']"" S OSGY(I)=" "
.F I=0:0 S I=$O(OSGY(I)) Q:'I I $G(SGY(I))']"" S SGY(I)=" "
Q
OTHL ;other lang. mod
;IHS/CIA/PLS - 02/03/04 - Use IHS Site paramter for wrap width
;K P,PP,L,SPSIG,SIG9,OSIG,SIG2,OSGY S PSLONG=46,OI=$P(^PSRX(RX,"OR1"),"^")
K P,PP,L,SPSIG,SIG9,OSIG,SIG2,OSGY S PSLONG=$S($$GET1^DIQ(9009033,PSOSITE,3):$$GET1^DIQ(9009033,PSOSITE,3),1:34),OI=$P(^PSRX(RX,"OR1"),"^")
F I=0:0 S I=$O(^PSRX(RX,6,I)) Q:'I S INST=^(I,0) D
.S SPSIG("DOSE",I)=$S($G(^PSRX(RX,6,I,1))]"":^PSRX(RX,6,I,1),1:$P(INST,"^")),SPSIG("DOSE ORDERED",I)=$P(INST,"^",2),SPSIG("UNITS",I)=$P(INST,"^",3),SPSIG("NOUN",I)=$P(INST,"^",4)
.I $P(INST,"^",5)]"" S SPSIG("DURATION",I)=$S($E($P(INST,"^",5),1)'?.N:$E($P(INST,"^",5),2,99)_$E($P(INST,"^",5),1),1:$P(INST,"^",5))
.S SPSIG("ROUTE",I)=$P(INST,"^",7),SPSIG("SCHEDULE",I)=$P(INST,"^",8)
.S SPSIG("CONJUNCTION",I)=$P(INST,"^",6),SPSIG("VERB",I)=$P(INST,"^",9)
S SPSIG("SIG",1)=$S($G(^PSRX(RX,"INSS"))]"":^PSRX(RX,"INSS"),1:"")
NX K I,T S OTHL=1 D EN^PSOSPSIG(.SPSIG)
S PP=1 F P=0:0 S P=$O(^PSRX(RX,"SIG1",P)) Q:'P I $G(^PSRX(RX,"SIG1",P,0))'="" S OSIG(PP)=^(0) S PP=PP+1
S (LVAR,LVAR1)="",L=1
F F=0:0 S F=$O(OSIG(F)) Q:'F S SGCT=0 F Z=1:1:$L(OSIG(F)) I $E(OSIG(F),Z)=" "!($L(OSIG(F))=Z) S SGCT=SGCT+1 D I $L(LVAR)>PSLONG S OSGY(L)=LLIM_" ",L=L+1,LVAR=LVAR1
.S LVAR1=$P(OSIG(F)," ",(SGCT)),LLIM=LVAR,LVAR=$S(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
I $G(LVAR)'="" S OSGY(L)=LVAR
I '$P(PSOPAR,"^",28) S SGC=0 F CTCT=0:0 S CTCT=$O(OSGY(CTCT)) Q:'CTCT S SGC=SGC+1
K OI,SPSIG,INST,I,T,OTHL,L,PP,P,OSIG,F
Q
OTHL1(RX) ;builds cmop other lang. sig for transmission
D OTHL K SIG9,PSLONG,OI
Q
PSOLBL3 ;BHAM ISC/RTR-Label utility routine ;29-May-2012 14:51;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**117,1009,1015**;DEC 1997;Build 62
+2 ;External reference ^PS(55 supported by DBIA 2228
+3 ;
+4 ;RX must be defined (Internal), Check already done for OERR SIG
+5 ;Format OERR Sig for New and Old label stock
+6 ; Modified - IHS/CIA/PLS - 02/02/04 - PSOLBL3+9 and OTHL+1
+7 ; IHS/MSC/PLS - 07/29/10 - PSOLBL3+12 and OTHL+1
+8 NEW CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,OSIG,ZZZZ,PSLONG,PPPP
+9 IF $PIECE($GET(^PS(55,DFN,"LAN")),"^")
DO OTHL
IF $GET(FND)
GOTO FMSIG
+10 ;IHS/CIA/PLS - 02/02/04 - Use IHS Site parameter for wrap width
+11 ;S PSLONG=$S($P(PSOPAR,"^",28):46,1:34)
+12 ;IHS/MSC/PLS - 07/29/2010 - Fix for undefined %APSITE when tasked
+13 ;1:$P(%APSITE,U,4))
SET PSLONG=$SELECT($PIECE(PSOPAR,"^",28):46,$$GET1^DIQ(9009033,PSOSITE,3):$$GET1^DIQ(9009033,PSOSITE,3),1:34)
+14 ; NEXT LINE IF SIG IS MOVED BACK TO MULTIPLE
+15 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
+16 ;NEXT LINE IF 1ST FRONT DOOR SIG LINE LIVES IN BACK DOOR SPOT
+17 ;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
FMSIG SET (LVAR,LVAR1)=""
SET LLLL=1
+1 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
+2 SET LVAR1=$PIECE(SIG9(FFFF)," ",(SGCT))
+3 SET LLIM=LVAR
+4 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
+5 IF $GET(LVAR)'=""
SET SGY(LLLL)=LVAR
+6 IF '$PIECE(PSOPAR,"^",28)
SET SGC=0
FOR CTCT=0:0
SET CTCT=$ORDER(SGY(CTCT))
IF 'CTCT
QUIT
SET SGC=SGC+1
+7 IF $ORDER(OSGY(0))
Begin DoDot:1
+8 FOR I=0:0
SET I=$ORDER(SGY(I))
IF 'I
QUIT
IF $GET(OSGY(I))']""
SET OSGY(I)=" "
+9 FOR I=0:0
SET I=$ORDER(OSGY(I))
IF 'I
QUIT
IF $GET(SGY(I))']""
SET SGY(I)=" "
End DoDot:1
+10 QUIT
OTHL ;other lang. mod
+1 ;IHS/CIA/PLS - 02/03/04 - Use IHS Site paramter for wrap width
+2 ;K P,PP,L,SPSIG,SIG9,OSIG,SIG2,OSGY S PSLONG=46,OI=$P(^PSRX(RX,"OR1"),"^")
+3 KILL P,PP,L,SPSIG,SIG9,OSIG,SIG2,OSGY
SET PSLONG=$SELECT($$GET1^DIQ(9009033,PSOSITE,3):$$GET1^DIQ(9009033,PSOSITE,3),1:34)
SET OI=$PIECE(^PSRX(RX,"OR1"),"^")
+4 FOR I=0:0
SET I=$ORDER(^PSRX(RX,6,I))
IF 'I
QUIT
SET INST=^(I,0)
Begin DoDot:1
+5 SET SPSIG("DOSE",I)=$SELECT($GET(^PSRX(RX,6,I,1))]"":^PSRX(RX,6,I,1),1:$PIECE(INST,"^"))
SET SPSIG("DOSE ORDERED",I)=$PIECE(INST,"^",2)
SET SPSIG("UNITS",I)=$PIECE(INST,"^",3)
SET SPSIG("NOUN",I)=$PIECE(INST,"^",4)
+6 IF $PIECE(INST,"^",5)]""
SET SPSIG("DURATION",I)=$SELECT($EXTRACT($PIECE(INST,"^",5),1)'?.N:$EXTRACT($PIECE(INST,"^",5),2,99)_$EXTRACT($PIECE(INST,"^",5),1),1:$PIECE(INST,"^",5))
+7 SET SPSIG("ROUTE",I)=$PIECE(INST,"^",7)
SET SPSIG("SCHEDULE",I)=$PIECE(INST,"^",8)
+8 SET SPSIG("CONJUNCTION",I)=$PIECE(INST,"^",6)
SET SPSIG("VERB",I)=$PIECE(INST,"^",9)
End DoDot:1
+9 SET SPSIG("SIG",1)=$SELECT($GET(^PSRX(RX,"INSS"))]"":^PSRX(RX,"INSS"),1:"")
NX KILL I,T
SET OTHL=1
DO EN^PSOSPSIG(.SPSIG)
+1 SET PP=1
FOR P=0:0
SET P=$ORDER(^PSRX(RX,"SIG1",P))
IF 'P
QUIT
IF $GET(^PSRX(RX,"SIG1",P,0))'=""
SET OSIG(PP)=^(0)
SET PP=PP+1
+2 SET (LVAR,LVAR1)=""
SET L=1
+3 FOR F=0:0
SET F=$ORDER(OSIG(F))
IF 'F
QUIT
SET SGCT=0
FOR Z=1:1:$LENGTH(OSIG(F))
IF $EXTRACT(OSIG(F),Z)=" "!($LENGTH(OSIG(F))=Z)
SET SGCT=SGCT+1
Begin DoDot:1
+4 SET LVAR1=$PIECE(OSIG(F)," ",(SGCT))
SET LLIM=LVAR
SET LVAR=$SELECT(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
End DoDot:1
IF $LENGTH(LVAR)>PSLONG
SET OSGY(L)=LLIM_" "
SET L=L+1
SET LVAR=LVAR1
+5 IF $GET(LVAR)'=""
SET OSGY(L)=LVAR
+6 IF '$PIECE(PSOPAR,"^",28)
SET SGC=0
FOR CTCT=0:0
SET CTCT=$ORDER(OSGY(CTCT))
IF 'CTCT
QUIT
SET SGC=SGC+1
+7 KILL OI,SPSIG,INST,I,T,OTHL,L,PP,P,OSIG,F
+8 QUIT
OTHL1(RX) ;builds cmop other lang. sig for transmission
+1 DO OTHL
KILL SIG9,PSLONG,OI
+2 QUIT
