PSGMUTL ;BIR/MV-UTLILITY USE FOR THE MAR AND MEDWS. ;15 SEP 97 / 2:10 PM
;;5.0;INPATIENT MEDICATIONS;**50,104,110,111,131,267**;16 DEC 97;Build 158
;
; Reference to ^PS(55 is supported by DBIA 2191.
;
MARFORM ;Prompt for the MAR form (Blank and Non-blank)
S DIR(0)="SA^1:Print Blank MARs only;2:Print Non-Blank MARs only;3:Print both Blank and Non-Blank MARs"
S DIR("A")="Select the MAR forms: ",DIR("B")="3"
S DIR("?")=""
S DIR("?",1)="Enter 1 to print BLANK (no data) MARs for the patient(s) you select."
S DIR("?",2)="Enter 2 to print MARs complete with orders."
S DIR("?",3)="Enter 3 to print both the blank MARs and the MARs complete with orders."
S DIR("?",4)="Enter an '^' to exit this option now."
D ^DIR S PSGMARB=$S($D(DIRUT):0,1:Y)
Q
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,X1,Y D SPLIT K MARX
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="" D
.. I $E(MARX(X1-1),$L(MARX(X1-1)))'=" " Q
.. S MARX(X1-1)=$E(MARX(X1-1),1,$L(MARX(X1-1))-1)
. S Y=Y_OLD(X)
S:Y]"" MARX(X1)=Y
S MARX=X1
Q
;
LONGTXT(LEN,DFN,ORDER) ; Build array of long special instructions
N TXTLN,TXT,I,TMPMARX,MARXTXT,LAST,II K MARX S LAST=0,TMPMARX=""
I ORDER["U" S TXTLN=0 F I=1:1 S TXTLN=$O(^PS(55,DFN,5,+ORDER,15,TXTLN)) Q:'TXTLN D
.S MARXTXT=^PS(55,DFN,5,+ORDER,15,TXTLN,0) D TXT(MARXTXT,LEN) S LAST=$O(TMPMARX(" "),-1) S II=0 F S II=$O(MARX(II)) Q:'II S TMPMARX(LAST+II)=MARX(II)
I ORDER["P" S TXTLN=0 F I=1:1 S TXTLN=$O(^PS(53.1,+ORDER,15,TXTLN)) Q:'TXTLN D
.S MARXTXT=^PS(53.1,+ORDER,15,TXTLN,0) D TXT(MARXTXT,LEN) S LAST=$O(TMPMARX(" "),-1) S II=0 F S II=$O(MARX(II)) Q:'II S TMPMARX(LAST+II)=MARX(II)
K MARX M MARX=TMPMARX
Q $O(MARX(0))
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 length
NEW X
Q:$L(OLD)'>LEN
S X=$E(OLD,1,($L(OLD)-1)) I X["/"!((X["-")&(X'["ON-CALL")) 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 K ONCALL F Y=1:1:$L(OLD(X),BSD) D
. Q:($G(ONCALL)=Y) ; If ON-CALL is delimited string, ignore
. 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
. I BSD="-",OLD(X)["ON-CALL" D ;If dashes, check for ON-CALL
.. S NEW(X1)=OLD(X),ONCALL=Y+1 ;Keep ON-CALL intact
. 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=LENGTH
NEW L,X,TXT K MARLB,DRUGNAME,ON S ON=PSGORD D ONHOLD^PSGMMAR2
S L=1
S MARLB(L)=$$BLANK(6)_"|"_$$BLANK(12)_"|",L=L+1
I $G(PST)["CZ"!($G(PST)["OZ") S MARLB(L)=PSGLOD_" | P E N D I N G"
E S MARLB(L)=PSGLOD_" |"_PSGLSD_" |"_PSGLFD
I $G(ONHOLD) S MARLB(L)=PSGLOD_" | O N H O L D "
S MARLB(L)=$$SETSTR^VALM1("("_$E(PPN)_$E(PSSN,8,12)_")",MARLB(L),40,7)
S L=L+1
D DRGDISP^PSJLMUT1(PSGP,+PSGORD_$S(PSGORD["P":"P",1:"U"),45,39,.DRUGNAME,0)
F X=0:0 S X=$O(DRUGNAME(X)) Q:'X S MARLB(L)=DRUGNAME(X)_$S(X=1:$$BLANK(47-$L(DRUGNAME(X)))_PSGLST,1:""),L=L+1
I '$$LONGTXT(LEN,DFN,PSGORD) 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
I $G(PSGP),$G(PSGORD),(PSGLRN]""),(PSGLRN'="O") D
.N ND4 S ND4=$S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,4)),PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:"")
.N PSGLREN,PSGLRNDT S PSGLREN=+$$LASTREN^PSJLMPRI(PSGP,PSGORD),PSGLRNDT=$P(ND4,"^",2) I PSGLREN,PSGLRNDT I PSGLREN>PSGLRNDT S PSGLRN=""
S X=$E("WS",1,PSGLWS*2)_$S(PSGLSM:$E("HSM",PSGLSM,3),1:"")_$E("NF",1,PSGLNF*2)
I X="",($L(MARLB(L-1))<30),(L=6) S L=L-1 D
. S X=MARLB(L)_$$BLANK(29-$L(MARLB(L)))_"RPH: "_$S(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"_____")
. S X=X_$$BLANK(39-$L(X))_"RN: "_$S(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
. S MARLB(L)=X
E D
. S:L=4 MARLB(5)="",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(29-$L(X))_"RPH: "_$S(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"____")
. S X=X_$$BLANK(39-$L(X))_"RN: "_$S(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
. S MARLB(L)=X
S L=L+1,MARLB(L)=""
S MARLB=L
I MARLB>6!($G(TS)>6) D MARLB2
Q
;
MARLB2 ;Split array into 2 labels.
;TS array must be defined. (TS^PSGMAR3(ADMIN TIMES))
NEW INIT,X,Y
S INIT=MARLB(MARLB),Y=6
F X=6:1:MARLB S X(X)=MARLB(X)
F X=6:1:($S(MARLB>TS:MARLB,1:TS)-1) D
. I (X#6)=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#6)=0 S MARLB(X)="",X=X+1
S MARLB(X)=INIT,MARLB=X
Q
N X F X=6:1:MARLB S X(X+1)=MARLB(X)
S MARLB(6)="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(12)=X(MARLB+1)
S MARLB=12
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMUTL 5308 printed Jan 18, 2025@03:02:57 Page 2
PSGMUTL ;BIR/MV-UTLILITY USE FOR THE MAR AND MEDWS. ;15 SEP 97 / 2:10 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**50,104,110,111,131,267**;16 DEC 97;Build 158
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
MARFORM ;Prompt for the MAR form (Blank and Non-blank)
+1 SET DIR(0)="SA^1:Print Blank MARs only;2:Print Non-Blank MARs only;3:Print both Blank and Non-Blank MARs"
+2 SET DIR("A")="Select the MAR forms: "
SET DIR("B")="3"
+3 SET DIR("?")=""
+4 SET DIR("?",1)="Enter 1 to print BLANK (no data) MARs for the patient(s) you select."
+5 SET DIR("?",2)="Enter 2 to print MARs complete with orders."
+6 SET DIR("?",3)="Enter 3 to print both the blank MARs and the MARs complete with orders."
+7 SET DIR("?",4)="Enter an '^' to exit this option now."
+8 DO ^DIR
SET PSGMARB=$SELECT($DATA(DIRUT):0,1:Y)
+9 QUIT
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,X1,Y
DO SPLIT
KILL MARX
+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=""
Begin DoDot:2
+8 IF $EXTRACT(MARX(X1-1),$LENGTH(MARX(X1-1)))'=" "
QUIT
+9 SET MARX(X1-1)=$EXTRACT(MARX(X1-1),1,$LENGTH(MARX(X1-1))-1)
End DoDot:2
+10 SET Y=Y_OLD(X)
End DoDot:1
+11 if Y]""
SET MARX(X1)=Y
+12 SET MARX=X1
+13 QUIT
+14 ;
LONGTXT(LEN,DFN,ORDER) ; Build array of long special instructions
+1 NEW TXTLN,TXT,I,TMPMARX,MARXTXT,LAST,II
KILL MARX
SET LAST=0
SET TMPMARX=""
+2 IF ORDER["U"
SET TXTLN=0
FOR I=1:1
SET TXTLN=$ORDER(^PS(55,DFN,5,+ORDER,15,TXTLN))
if 'TXTLN
QUIT
Begin DoDot:1
+3 SET MARXTXT=^PS(55,DFN,5,+ORDER,15,TXTLN,0)
DO TXT(MARXTXT,LEN)
SET LAST=$ORDER(TMPMARX(" "),-1)
SET II=0
FOR
SET II=$ORDER(MARX(II))
if 'II
QUIT
SET TMPMARX(LAST+II)=MARX(II)
End DoDot:1
+4 IF ORDER["P"
SET TXTLN=0
FOR I=1:1
SET TXTLN=$ORDER(^PS(53.1,+ORDER,15,TXTLN))
if 'TXTLN
QUIT
Begin DoDot:1
+5 SET MARXTXT=^PS(53.1,+ORDER,15,TXTLN,0)
DO TXT(MARXTXT,LEN)
SET LAST=$ORDER(TMPMARX(" "),-1)
SET II=0
FOR
SET II=$ORDER(MARX(II))
if 'II
QUIT
SET TMPMARX(LAST+II)=MARX(II)
End DoDot:1
+6 KILL MARX
MERGE MARX=TMPMARX
+7 QUIT $ORDER(MARX(0))
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 length
+1 NEW X
+2 if $LENGTH(OLD)'>LEN
QUIT
+3 SET X=$EXTRACT(OLD,1,($LENGTH(OLD)-1))
IF X["/"!((X["-")&(X'["ON-CALL"))
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
KILL ONCALL
FOR Y=1:1:$LENGTH(OLD(X),BSD)
Begin DoDot:1
+3 ; If ON-CALL is delimited string, ignore
if ($GET(ONCALL)=Y)
QUIT
+4 SET X1=X1+1
+5 SET NEW(X1)=$PIECE(OLD(X),BSD,Y)
+6 IF $LENGTH(OLD(X),BSD)>1
IF (Y<$LENGTH(OLD(X),BSD))
SET NEW(X1)=NEW(X1)_BSD
+7 ;If dashes, check for ON-CALL
IF BSD="-"
IF OLD(X)["ON-CALL"
Begin DoDot:2
+8 ;Keep ON-CALL intact
SET NEW(X1)=OLD(X)
SET ONCALL=Y+1
End DoDot:2
+9 DO LEN(.X1,NEW(X1))
End DoDot:1
+10 KILL OLD
FOR X=0:0
SET X=$ORDER(NEW(X))
if 'X
QUIT
SET OLD(X)=NEW(X)
+11 QUIT
+12 ;
MARLB(LEN) ;
+1 ;;;LEN=LENGTH
+2 NEW L,X,TXT
KILL MARLB,DRUGNAME,ON
SET ON=PSGORD
DO ONHOLD^PSGMMAR2
+3 SET L=1
+4 SET MARLB(L)=$$BLANK(6)_"|"_$$BLANK(12)_"|"
SET L=L+1
+5 IF $GET(PST)["CZ"!($GET(PST)["OZ")
SET MARLB(L)=PSGLOD_" | P E N D I N G"
+6 IF '$TEST
SET MARLB(L)=PSGLOD_" |"_PSGLSD_" |"_PSGLFD
+7 IF $GET(ONHOLD)
SET MARLB(L)=PSGLOD_" | O N H O L D "
+8 SET MARLB(L)=$$SETSTR^VALM1("("_$EXTRACT(PPN)_$EXTRACT(PSSN,8,12)_")",MARLB(L),40,7)
+9 SET L=L+1
+10 DO DRGDISP^PSJLMUT1(PSGP,+PSGORD_$SELECT(PSGORD["P":"P",1:"U"),45,39,.DRUGNAME,0)
+11 FOR X=0:0
SET X=$ORDER(DRUGNAME(X))
if 'X
QUIT
SET MARLB(L)=DRUGNAME(X)_$SELECT(X=1:$$BLANK(47-$LENGTH(DRUGNAME(X)))_PSGLST,1:"")
SET L=L+1
+12 IF '$$LONGTXT(LEN,DFN,PSGORD)
DO TXT^PSGMUTL(PSGLSI,LEN)
+13 SET X=0
FOR
SET X=$ORDER(MARX(X))
if 'X
QUIT
SET MARLB(L)=MARX(X)
SET L=L+1
+14 KILL MARX
+15 IF $GET(PSGP)
IF $GET(PSGORD)
IF (PSGLRN]"")
IF (PSGLRN'="O")
Begin DoDot:1
+16 NEW ND4
SET ND4=$SELECT(PSGORD["U":$GET(^PS(55,PSGP,5,+PSGORD,4)),PSGORD["P":$GET(^PS(53.1,+PSGORD,4)),1:"")
+17 NEW PSGLREN,PSGLRNDT
SET PSGLREN=+$$LASTREN^PSJLMPRI(PSGP,PSGORD)
SET PSGLRNDT=$PIECE(ND4,"^",2)
IF PSGLREN
IF PSGLRNDT
IF PSGLREN>PSGLRNDT
SET PSGLRN=""
End DoDot:1
+18 SET X=$EXTRACT("WS",1,PSGLWS*2)_$SELECT(PSGLSM:$EXTRACT("HSM",PSGLSM,3),1:"")_$EXTRACT("NF",1,PSGLNF*2)
+19 IF X=""
IF ($LENGTH(MARLB(L-1))<30)
IF (L=6)
SET L=L-1
Begin DoDot:1
+20 SET X=MARLB(L)_$$BLANK(29-$LENGTH(MARLB(L)))_"RPH: "_$SELECT(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"_____")
+21 SET X=X_$$BLANK(39-$LENGTH(X))_"RN: "_$SELECT(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
+22 SET MARLB(L)=X
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 if L=4
SET MARLB(5)=""
SET L=5
+25 SET X=$EXTRACT("WS",1,PSGLWS*2)
+26 SET X=X_$$BLANK(4-$LENGTH(X))_$SELECT(PSGLSM:$EXTRACT("HSM",PSGLSM,3),1:"")
+27 SET X=X_$$BLANK(8-$LENGTH(X))_$EXTRACT("NF",1,PSGLNF*2)
+28 SET X=X_$$BLANK(29-$LENGTH(X))_"RPH: "_$SELECT(PSGLRPH]""&(PSGLRPH'="0"):PSGLRPH,1:"____")
+29 SET X=X_$$BLANK(39-$LENGTH(X))_"RN: "_$SELECT(PSGLRN]""&(PSGLRN'="0"):PSGLRN,1:"_____")
+30 SET MARLB(L)=X
End DoDot:1
+31 SET L=L+1
SET MARLB(L)=""
+32 SET MARLB=L
+33 IF MARLB>6!($GET(TS)>6)
DO MARLB2
+34 QUIT
+35 ;
MARLB2 ;Split 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=6
+4 FOR X=6:1:MARLB
SET X(X)=MARLB(X)
+5 FOR X=6:1:($SELECT(MARLB>TS:MARLB,1:TS)-1)
Begin DoDot:1
+6 IF (X#6)=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#6)=0
QUIT
SET MARLB(X)=""
SET X=X+1
+11 SET MARLB(X)=INIT
SET MARLB=X
+12 QUIT
+13 NEW X
FOR X=6:1:MARLB
SET X(X+1)=MARLB(X)
+14 SET MARLB(6)="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(12)=X(MARLB+1)
+18 SET MARLB=12
+19 QUIT
+20 ;
