- 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 ;