PSJORMA1 ;BIR/MV-COLLECT MAR DATA FOR U/D AND INPATIENT MED PENDINGS. ; 10 Mar 98 / 8:50 AM
;;5.0; INPATIENT MEDICATIONS ;**2**;16 DEC 97
BLANK(LEN) ;
NEW X
S $P(X," ",LEN)=" "
Q $G(X)
;
TXT(TXT,LEN) ;
;* Input: TXT = TXT string
;* LEN = format length
;* Output: MARX array.
;*
NEW OLD D SPLIT
S X=0,X1=1,Y="" F S X=$O(OLD(X)) Q:'X D
. I $L(Y_OLD(X))>LEN S MARX(X1)=Y,X1=X1+1,Y=""
. S Y=Y_OLD(X)
S:Y]"" MARX(X1)=Y
S MARX=X1
Q
;
SPLIT ;* Split a word string into individual words.
;* Output: OLD(X)
;*
NEW BSD,NEW,X,X1,Y
S OLD(1)=TXT Q:$L(TXT)<LEN
F BSD=" ","/","-" S:'$O(OLD(0)) OLD(1)=TXT D:TXT[BSD DELIM(BSD)
I '$O(OLD(1)),($L(TXT)>LEN) D LEN(1,TXT) K OLD D
. F X=0:0 S X=$O(NEW(X)) Q:'X S OLD(X)=NEW(X)
Q
LEN(X1,OLD) ;* Wrap word around if it doesn't fit the display lenght.
NEW X
Q:$L(OLD)'>LEN
S X=$E(OLD,1,($L(OLD)-1)) I X["/"!(X["-") Q
I $L(OLD)>LEN F X=1:1 S NEW(X1)=$E(OLD,((LEN*X)-LEN+1),(LEN*X)),X1=X1+1 Q:($L(OLD)'>(LEN*X))
Q
DELIM(BSD) ;* BSD=" ","/","-"
K NEW
S X=0,X1=0 F S X=$O(OLD(X)) Q:'X F Y=1:1:$L(OLD(X),BSD) D
. S X1=X1+1
. S NEW(X1)=$P(OLD(X),BSD,Y)
. I $L(OLD(X),BSD)>1,(Y<$L(OLD(X),BSD)) S NEW(X1)=NEW(X1)_BSD
. D LEN(.X1,NEW(X1))
K OLD F X=0:0 S X=$O(NEW(X)) Q:'X S OLD(X)=NEW(X)
Q
;
MARLB(LEN) ;
;;;LEN=LENGHT
NEW L,X,TXT K MARLB,DRUGNAME
S L=1
;I ON["P",(PSGLRN["___") S MARLB(L)=PSGLOD_" | P E N D I N G"
I ON["P",+NODE(4) S MARLB(L)=PSGLOD_" | P E N D I N G"
E S MARLB(L)=PSGLOD_" |"_PSGLSD_" |"_PSGLFD
S MARLB(L)=$$SETSTR^VALM1("("_PSGLBS5_")",MARLB(L),36,7)
S L=L+1
D DRGDISP^PSJLMUT1(DFN,PSGORD,LEN,39,.DRUGNAME,0)
F X=0:0 S X=$O(DRUGNAME(X)) Q:'X S MARLB(L)=DRUGNAME(X)_$S(X=1:$$BLANK(41-$L(DRUGNAME(X)))_PSGLST,1:""),L=L+1
D TXT^PSGMUTL(PSGLSI,LEN)
S X=0 F S X=$O(MARX(X)) Q:'X S MARLB(L)=MARX(X),L=L+1
K MARX
S X=$E("WS",1,PSGLWS*2)_$S(PSGLSM:$E("HSM",PSGLSM,3),1:"")_$E("NF",1,PSGLNF*2)
I TS<L,(X=""),($L(MARLB(L-1))<24),(L=6) S L=L-1 D
. S X=MARLB(L)_$$BLANK(23-$L(MARLB(L)))_"RPH: "_$S(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"_____")
. S X=X_$$BLANK(33-$L(X))_"RN: "_$S(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
. S MARLB(L)=X
E D
. I L#5>0 F L=L:1:5 S MARLB(L)=""
.; S:L=4 MARLB(4)="",L=5
. S X=$E("WS",1,PSGLWS*2)
. S X=X_$$BLANK(4-$L(X))_$S(PSGLSM:$E("HSM",PSGLSM,3),1:"")
. S X=X_$$BLANK(8-$L(X))_$E("NF",1,PSGLNF*2)
. S X=X_$$BLANK(23-$L(X))_"RPH: "_$S(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"____")
. S X=X_$$BLANK(33-$L(X))_"RN: "_$S(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
. S MARLB(L)=X
S MARLB=L
I MARLB>5!($G(TS)>5) D MARLB2
Q
;
MARLB2 ;Slit array into 2 labels.
;TS array must be defined. (TS^PSGMAR3(ADMIN TIMES))
NEW INIT,X,Y
S INIT=MARLB(MARLB),Y=5
F X=5:1:MARLB S X(X)=MARLB(X)
F X=5:1:($S(MARLB>TS:MARLB,1:TS)-1) D
. I (X#5)=0 S MARLB(X)="See next label for continuation" Q
. I Y<(MARLB) S MARLB(X)=X(Y),Y=Y+1 Q
. S MARLB(X)=""
S X=X+1 F Y=Y:1:MARLB-1 S MARLB(X)=$G(X(Y)),X=X+1
F X=X:0 Q:(X#5)=0 S MARLB(X)="",X=X+1
S MARLB(X)=INIT,MARLB=X
Q
N X F X=5:1:MARLB S X(X+1)=MARLB(X)
S MARLB(5)="See next label for continuation"
F X=7:1:MARLB S MARLB(X)=X(X)
F X=X+1:1:11 S MARLB(X)=""
S MARLB(10)=X(MARLB+1)
S MARLB=10
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJORMA1 3287 printed Sep 23, 2025@19:44:25 Page 2
PSJORMA1 ;BIR/MV-COLLECT MAR DATA FOR U/D AND INPATIENT MED PENDINGS. ; 10 Mar 98 / 8:50 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**2**;16 DEC 97
BLANK(LEN) ;
+1 NEW X
+2 SET $PIECE(X," ",LEN)=" "
+3 QUIT $GET(X)
+4 ;
TXT(TXT,LEN) ;
+1 ;* Input: TXT = TXT string
+2 ;* LEN = format length
+3 ;* Output: MARX array.
+4 ;*
+5 NEW OLD
DO SPLIT
+6 SET X=0
SET X1=1
SET Y=""
FOR
SET X=$ORDER(OLD(X))
if 'X
QUIT
Begin DoDot:1
+7 IF $LENGTH(Y_OLD(X))>LEN
SET MARX(X1)=Y
SET X1=X1+1
SET Y=""
+8 SET Y=Y_OLD(X)
End DoDot:1
+9 if Y]""
SET MARX(X1)=Y
+10 SET MARX=X1
+11 QUIT
+12 ;
SPLIT ;* Split a word string into individual words.
+1 ;* Output: OLD(X)
+2 ;*
+3 NEW BSD,NEW,X,X1,Y
+4 SET OLD(1)=TXT
if $LENGTH(TXT)<LEN
QUIT
+5 FOR BSD=" ","/","-"
if '$ORDER(OLD(0))
SET OLD(1)=TXT
if TXT[BSD
DO DELIM(BSD)
+6 IF '$ORDER(OLD(1))
IF ($LENGTH(TXT)>LEN)
DO LEN(1,TXT)
KILL OLD
Begin DoDot:1
+7 FOR X=0:0
SET X=$ORDER(NEW(X))
if 'X
QUIT
SET OLD(X)=NEW(X)
End DoDot:1
+8 QUIT
LEN(X1,OLD) ;* Wrap word around if it doesn't fit the display lenght.
+1 NEW X
+2 if $LENGTH(OLD)'>LEN
QUIT
+3 SET X=$EXTRACT(OLD,1,($LENGTH(OLD)-1))
IF X["/"!(X["-")
QUIT
+4 IF $LENGTH(OLD)>LEN
FOR X=1:1
SET NEW(X1)=$EXTRACT(OLD,((LEN*X)-LEN+1),(LEN*X))
SET X1=X1+1
if ($LENGTH(OLD)'>(LEN*X))
QUIT
+5 QUIT
DELIM(BSD) ;* BSD=" ","/","-"
+1 KILL NEW
+2 SET X=0
SET X1=0
FOR
SET X=$ORDER(OLD(X))
if 'X
QUIT
FOR Y=1:1:$LENGTH(OLD(X),BSD)
Begin DoDot:1
+3 SET X1=X1+1
+4 SET NEW(X1)=$PIECE(OLD(X),BSD,Y)
+5 IF $LENGTH(OLD(X),BSD)>1
IF (Y<$LENGTH(OLD(X),BSD))
SET NEW(X1)=NEW(X1)_BSD
+6 DO LEN(.X1,NEW(X1))
End DoDot:1
+7 KILL OLD
FOR X=0:0
SET X=$ORDER(NEW(X))
if 'X
QUIT
SET OLD(X)=NEW(X)
+8 QUIT
+9 ;
MARLB(LEN) ;
+1 ;;;LEN=LENGHT
+2 NEW L,X,TXT
KILL MARLB,DRUGNAME
+3 SET L=1
+4 ;I ON["P",(PSGLRN["___") S MARLB(L)=PSGLOD_" | P E N D I N G"
+5 IF ON["P"
IF +NODE(4)
SET MARLB(L)=PSGLOD_" | P E N D I N G"
+6 IF '$TEST
SET MARLB(L)=PSGLOD_" |"_PSGLSD_" |"_PSGLFD
+7 SET MARLB(L)=$$SETSTR^VALM1("("_PSGLBS5_")",MARLB(L),36,7)
+8 SET L=L+1
+9 DO DRGDISP^PSJLMUT1(DFN,PSGORD,LEN,39,.DRUGNAME,0)
+10 FOR X=0:0
SET X=$ORDER(DRUGNAME(X))
if 'X
QUIT
SET MARLB(L)=DRUGNAME(X)_$SELECT(X=1:$$BLANK(41-$LENGTH(DRUGNAME(X)))_PSGLST,1:"")
SET L=L+1
+11 DO TXT^PSGMUTL(PSGLSI,LEN)
+12 SET X=0
FOR
SET X=$ORDER(MARX(X))
if 'X
QUIT
SET MARLB(L)=MARX(X)
SET L=L+1
+13 KILL MARX
+14 SET X=$EXTRACT("WS",1,PSGLWS*2)_$SELECT(PSGLSM:$EXTRACT("HSM",PSGLSM,3),1:"")_$EXTRACT("NF",1,PSGLNF*2)
+15 IF TS<L
IF (X="")
IF ($LENGTH(MARLB(L-1))<24)
IF (L=6)
SET L=L-1
Begin DoDot:1
+16 SET X=MARLB(L)_$$BLANK(23-$LENGTH(MARLB(L)))_"RPH: "_$SELECT(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"_____")
+17 SET X=X_$$BLANK(33-$LENGTH(X))_"RN: "_$SELECT(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
+18 SET MARLB(L)=X
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 IF L#5>0
FOR L=L:1:5
SET MARLB(L)=""
+21 ; S:L=4 MARLB(4)="",L=5
+22 SET X=$EXTRACT("WS",1,PSGLWS*2)
+23 SET X=X_$$BLANK(4-$LENGTH(X))_$SELECT(PSGLSM:$EXTRACT("HSM",PSGLSM,3),1:"")
+24 SET X=X_$$BLANK(8-$LENGTH(X))_$EXTRACT("NF",1,PSGLNF*2)
+25 SET X=X_$$BLANK(23-$LENGTH(X))_"RPH: "_$SELECT(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"____")
+26 SET X=X_$$BLANK(33-$LENGTH(X))_"RN: "_$SELECT(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
+27 SET MARLB(L)=X
End DoDot:1
+28 SET MARLB=L
+29 IF MARLB>5!($GET(TS)>5)
DO MARLB2
+30 QUIT
+31 ;
MARLB2 ;Slit array into 2 labels.
+1 ;TS array must be defined. (TS^PSGMAR3(ADMIN TIMES))
+2 NEW INIT,X,Y
+3 SET INIT=MARLB(MARLB)
SET Y=5
+4 FOR X=5:1:MARLB
SET X(X)=MARLB(X)
+5 FOR X=5:1:($SELECT(MARLB>TS:MARLB,1:TS)-1)
Begin DoDot:1
+6 IF (X#5)=0
SET MARLB(X)="See next label for continuation"
QUIT
+7 IF Y<(MARLB)
SET MARLB(X)=X(Y)
SET Y=Y+1
QUIT
+8 SET MARLB(X)=""
End DoDot:1
+9 SET X=X+1
FOR Y=Y:1:MARLB-1
SET MARLB(X)=$GET(X(Y))
SET X=X+1
+10 FOR X=X:0
if (X#5)=0
QUIT
SET MARLB(X)=""
SET X=X+1
+11 SET MARLB(X)=INIT
SET MARLB=X
+12 QUIT
+13 NEW X
FOR X=5:1:MARLB
SET X(X+1)=MARLB(X)
+14 SET MARLB(5)="See next label for continuation"
+15 FOR X=7:1:MARLB
SET MARLB(X)=X(X)
+16 FOR X=X+1:1:11
SET MARLB(X)=""
+17 SET MARLB(10)=X(MARLB+1)
+18 SET MARLB=10
+19 QUIT
+20 ;
