- PSSUTLA2 ;BIR/RTR-Utility routine ;08/21/00
- ;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
- ;
- EN3(PSSBINTR,PSSBLGTH) ;
- ;Pass in to EN3 the internal number from 50.7, and the length of the
- ;array you want. Returns expanded Instructions is PSSBSIG array
- K PSSBSIG N X,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,PISIG,Z0,Z1,CNTZ,FFF
- Q:'$G(PSSBINTR)!('$G(PSSBLGTH))
- S X=$P($G(^PS(50.7,PSSBINTR,"INS")),"^") Q:X=""
- S PISIG(1)="",CNTZ=1 Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D G:'$D(X) START
- .D:$D(X)&($G(Z1)]"") D ADD
- ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P($G(^PS(51,Y,0)),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
- START ;
- S (BVAR,BVAR1)="",III=1
- F FFF=0:0 S FFF=$O(PISIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(PISIG(FFF)) I $E(PISIG(FFF),NNN)=" "!($L(PISIG(FFF))=NNN) S CNT=CNT+1 D I $L(BVAR)>PSSBLGTH S PSSBSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
- .S BVAR1=$P(PISIG(FFF)," ",(CNT))
- .S BLIM=BVAR
- .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
- I $G(BVAR)'="" S PSSBSIG(III)=BVAR
- I $G(PSSBSIG(1))=""!($G(PSSBSIG(1))=" ") S PSSBSIG(1)=$G(PSSBSIG(2)) K PSSBSIG(2)
- F CNTZ=0:0 S CNTZ=$O(PSSBSIG(CNTZ)) Q:'CNTZ S PSSX("PI",CNTZ)=$G(PSSBSIG(CNTZ))
- K PSSBSIG
- Q
- ADD ;
- I $L(PISIG(CNTZ))+$L(Z1)+1<246 S PISIG(CNTZ)=PISIG(CNTZ)_" "_Z1 Q
- S CNTZ=CNTZ+1 S PISIG(CNTZ)=Z1
- Q
- ;
- HELP ;
- Q:$G(X)=""
- N PSSSIG,PSSYX,PSSZ0,PSSZ1,PSSCTX,PSSLPX,PSSBVAR,PSSBVAR1,PSSIII,PSSFFF,PCT,PNNN,PSSBLIM,PSSIG
- S PSSIG(1)="",PSSCTX=1 Q:$L(X)<1 F PSSZ0=1:1:$L(X," ") G:PSSZ0="" HELP1 S PSSZ1=$P(X," ",PSSZ0) D G:'$D(X) HELP1
- .D:$D(X)&($G(PSSZ1)]"") D HELPADD
- ..S PSSYX=$O(^PS(51,"B",PSSZ1,0)) Q:'PSSYX!($P($G(^PS(51,+PSSYX,0)),"^",4)>1) S PSSZ1=$P($G(^PS(51,PSSYX,0)),"^",2) Q:'$D(^(9)) S PSSYX=$P(X," ",PSSZ0-1),PSSYX=$E(PSSYX,$L(PSSYX)) S:PSSYX>1 PSSZ1=^(9)
- HELP1 ;
- S (PSSBVAR,PSSBVAR1)="",PSSIII=1
- F PSSFFF=0:0 S PSSFFF=$O(PSSIG(PSSFFF)) Q:'PSSFFF S PCT=0 F PNNN=1:1:$L(PSSIG(PSSFFF)) I $E(PSSIG(PSSFFF),PNNN)=" "!($L(PSSIG(PSSFFF))=PNNN) S PCT=PCT+1 D I $L(PSSBVAR)>70 S PSSSIG(PSSIII)=PSSBLIM_" ",PSSIII=PSSIII+1,PSSBVAR=PSSBVAR1
- .S PSSBVAR1=$P(PSSIG(PSSFFF)," ",(PCT))
- .S PSSBLIM=PSSBVAR
- .S PSSBVAR=$S(PSSBVAR="":PSSBVAR1,1:PSSBVAR_" "_PSSBVAR1)
- I $G(PSSBVAR)'="" S PSSSIG(PSSIII)=PSSBVAR
- I $G(PSSSIG(1))=""!($G(PSSSIG(1))=" ") S PSSSIG(1)=$G(PSSSIG(2)) K PSSSIG(2)
- F PSSLPX=0:0 S PSSLPX=$O(PSSSIG(PSSLPX)) Q:'PSSLPX D:PSSLPX=1 EN^DDIOL(" ") D EN^DDIOL(" "_$G(PSSSIG(PSSLPX)))
- Q
- HELPADD ;
- I $L(PSSIG(PSSCTX))+$L(PSSZ1)+1<246 S PSSIG(PSSCTX)=PSSIG(PSSCTX)_" "_PSSZ1 Q
- S PSSCTX=PSSCTX+1 S PSSIG(PSSCTX)=PSSZ1
- Q
- PSSUTLA2 ;BIR/RTR-Utility routine ;08/21/00
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
- +2 ;
- EN3(PSSBINTR,PSSBLGTH) ;
- +1 ;Pass in to EN3 the internal number from 50.7, and the length of the
- +2 ;array you want. Returns expanded Instructions is PSSBSIG array
- +3 KILL PSSBSIG
- NEW X,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,PISIG,Z0,Z1,CNTZ,FFF
- +4 IF '$GET(PSSBINTR)!('$GET(PSSBLGTH))
- QUIT
- +5 SET X=$PIECE($GET(^PS(50.7,PSSBINTR,"INS")),"^")
- IF X=""
- QUIT
- +6 SET PISIG(1)=""
- SET CNTZ=1
- IF $LENGTH(X)<1
- QUIT
- FOR Z0=1:1:$LENGTH(X," ")
- IF Z0=""
- GOTO START
- SET Z1=$PIECE(X," ",Z0)
- Begin DoDot:1
- +7 IF $DATA(X)&($GET(Z1)]"")
- Begin DoDot:2
- +8 SET Y=$ORDER(^PS(51,"B",Z1,0))
- IF 'Y!($PIECE($GET(^PS(51,+Y,0)),"^",4)>1)
- QUIT
- SET Z1=$PIECE($GET(^PS(51,Y,0)),"^",2)
- IF '$DATA(^(9))
- QUIT
- SET Y=$PIECE(X," ",Z0-1)
- SET Y=$EXTRACT(Y,$LENGTH(Y))
- IF Y>1
- SET Z1=^(9)
- End DoDot:2
- DO ADD
- End DoDot:1
- IF '$DATA(X)
- GOTO START
- START ;
- +1 SET (BVAR,BVAR1)=""
- SET III=1
- +2 FOR FFF=0:0
- SET FFF=$ORDER(PISIG(FFF))
- IF 'FFF
- QUIT
- SET CNT=0
- FOR NNN=1:1:$LENGTH(PISIG(FFF))
- IF $EXTRACT(PISIG(FFF),NNN)=" "!($LENGTH(PISIG(FFF))=NNN)
- SET CNT=CNT+1
- Begin DoDot:1
- +3 SET BVAR1=$PIECE(PISIG(FFF)," ",(CNT))
- +4 SET BLIM=BVAR
- +5 SET BVAR=$SELECT(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
- End DoDot:1
- IF $LENGTH(BVAR)>PSSBLGTH
- SET PSSBSIG(III)=BLIM_" "
- SET III=III+1
- SET BVAR=BVAR1
- +6 IF $GET(BVAR)'=""
- SET PSSBSIG(III)=BVAR
- +7 IF $GET(PSSBSIG(1))=""!($GET(PSSBSIG(1))=" ")
- SET PSSBSIG(1)=$GET(PSSBSIG(2))
- KILL PSSBSIG(2)
- +8 FOR CNTZ=0:0
- SET CNTZ=$ORDER(PSSBSIG(CNTZ))
- IF 'CNTZ
- QUIT
- SET PSSX("PI",CNTZ)=$GET(PSSBSIG(CNTZ))
- +9 KILL PSSBSIG
- +10 QUIT
- ADD ;
- +1 IF $LENGTH(PISIG(CNTZ))+$LENGTH(Z1)+1<246
- SET PISIG(CNTZ)=PISIG(CNTZ)_" "_Z1
- QUIT
- +2 SET CNTZ=CNTZ+1
- SET PISIG(CNTZ)=Z1
- +3 QUIT
- +4 ;
- HELP ;
- +1 IF $GET(X)=""
- QUIT
- +2 NEW PSSSIG,PSSYX,PSSZ0,PSSZ1,PSSCTX,PSSLPX,PSSBVAR,PSSBVAR1,PSSIII,PSSFFF,PCT,PNNN,PSSBLIM,PSSIG
- +3 SET PSSIG(1)=""
- SET PSSCTX=1
- IF $LENGTH(X)<1
- QUIT
- FOR PSSZ0=1:1:$LENGTH(X," ")
- IF PSSZ0=""
- GOTO HELP1
- SET PSSZ1=$PIECE(X," ",PSSZ0)
- Begin DoDot:1
- +4 IF $DATA(X)&($GET(PSSZ1)]"")
- Begin DoDot:2
- +5 SET PSSYX=$ORDER(^PS(51,"B",PSSZ1,0))
- IF 'PSSYX!($PIECE($GET(^PS(51,+PSSYX,0)),"^",4)>1)
- QUIT
- SET PSSZ1=$PIECE($GET(^PS(51,PSSYX,0)),"^",2)
- IF '$DATA(^(9))
- QUIT
- SET PSSYX=$PIECE(X," ",PSSZ0-1)
- SET PSSYX=$EXTRACT(PSSYX,$LENGTH(PSSYX))
- IF PSSYX>1
- SET PSSZ1=^(9)
- End DoDot:2
- DO HELPADD
- End DoDot:1
- IF '$DATA(X)
- GOTO HELP1
- HELP1 ;
- +1 SET (PSSBVAR,PSSBVAR1)=""
- SET PSSIII=1
- +2 FOR PSSFFF=0:0
- SET PSSFFF=$ORDER(PSSIG(PSSFFF))
- IF 'PSSFFF
- QUIT
- SET PCT=0
- FOR PNNN=1:1:$LENGTH(PSSIG(PSSFFF))
- IF $EXTRACT(PSSIG(PSSFFF),PNNN)=" "!($LENGTH(PSSIG(PSSFFF))=PNNN)
- SET PCT=PCT+1
- Begin DoDot:1
- +3 SET PSSBVAR1=$PIECE(PSSIG(PSSFFF)," ",(PCT))
- +4 SET PSSBLIM=PSSBVAR
- +5 SET PSSBVAR=$SELECT(PSSBVAR="":PSSBVAR1,1:PSSBVAR_" "_PSSBVAR1)
- End DoDot:1
- IF $LENGTH(PSSBVAR)>70
- SET PSSSIG(PSSIII)=PSSBLIM_" "
- SET PSSIII=PSSIII+1
- SET PSSBVAR=PSSBVAR1
- +6 IF $GET(PSSBVAR)'=""
- SET PSSSIG(PSSIII)=PSSBVAR
- +7 IF $GET(PSSSIG(1))=""!($GET(PSSSIG(1))=" ")
- SET PSSSIG(1)=$GET(PSSSIG(2))
- KILL PSSSIG(2)
- +8 FOR PSSLPX=0:0
- SET PSSLPX=$ORDER(PSSSIG(PSSLPX))
- IF 'PSSLPX
- QUIT
- IF PSSLPX=1
- DO EN^DDIOL(" ")
- DO EN^DDIOL(" "_$GET(PSSSIG(PSSLPX)))
- +9 QUIT
- HELPADD ;
- +1 IF $LENGTH(PSSIG(PSSCTX))+$LENGTH(PSSZ1)+1<246
- SET PSSIG(PSSCTX)=PSSIG(PSSCTX)_" "_PSSZ1
- QUIT
- +2 SET PSSCTX=PSSCTX+1
- SET PSSIG(PSSCTX)=PSSZ1
- +3 QUIT
