PSOERXD1 ;ALB/BWF - eRx Drug display/actions ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,520,551,582,581,635,617,651,689,700,746,769**;DEC 1997;Build 26
;
EN ; -- main entry point for PSO ERX HOLDING QUEUE
D EN^VALM("PSO ERX DRUG VALIDATION")
Q
;
LMHDR ; ListMan Header Code
D SHOW^VALM,HDR^PSOERXD1
S ORMXQ("??")="D HELP^VALM2,HDR^PSOERXD1"
Q
;
HDR ; -- header code
N AMATCH,VDRGIEN,VALUSER,VALDTTM,MATCH,HDR,EFFDATE
S AMATCH=$$GET1^DIQ(52.49,PSOIEN,1.4,"I"),VDRGIEN=$$GET1^DIQ(52.49,PSOIEN,3.2,"I")
S VALUSER=$$GET1^DIQ(52.49,PSOIEN,1.11,"E"),VALDTTM=$$GET1^DIQ(52.49,PSOIEN,1.12,"I")
S VALMHDR(1)="eRx Reference #: "_IOINHI_$$GET1^DIQ(52.49,PSOIEN,.01,"E")_IOINORM
D INSTR^VALM1("eRx Patient: "_IOINHI_$$GET1^DIQ(52.49,PSOIEN,.04,"E")_IOINORM,32,2)
S VALMHDR(2)="Date Written : "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.49,PSOIEN,5.9,"I")\1,"2Y")_IOINORM
; Have to use INSTR^VALM1 to reach the end of the line (due to Listman issues/bug with formatting)
S EFFDATE="Effective Date: "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.49,PSOIEN,6.3,"I"),"2Y")_IOINORM
D INSTR^VALM1(EFFDATE,29,3)
S MATCH=$S(AMATCH=1:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VDRGIEN:"MANUALLY-MATCHED",1:"")
I VALUSER'="",MATCH'="" S MATCH=MATCH_" | VALIDATED by "_$E(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM,"2Y")
I MATCH="" S MATCH="NOT MATCHED"
S $E(MATCH,81)="" D INSTR^VALM1("Status: "_IOINHI_MATCH_IOINORM,1,4)
S HDR="",$E(HDR,17)="ERX MED",$E(HDR,40)="|",$E(HDR,56)="VISTA MED"
S $E(HDR,81)="" D INSTR^VALM1(IORVON_IOUON_HDR_IORVOFF_IOINORM,1,5)
Q
;
INIT ;
N I,LINE,REVLN,HIGHLN,UNDERLN,HIGUNDLN,DIE,DA,DR,NMSPC
S NMSPC="PSOERDR1" K ^TMP(NMSPC,$J)
; - Resetting list to NORMAL video attributes
D RESET^PSOERUT0()
S LINE=1
;
; Routing (Window/Mail)
I $$GET1^DIQ(52.49,PSOIEN,20.4,"E")="" D
. S DIE="^PS(52.49,",DA=PSOIEN,DR="20.4////M" D ^DIE K DIE
;
; Clinic
I '$$GET1^DIQ(52.49,PSOIEN,20.6,"I"),$G(PSOCLNC) D
. S DIE="^PS(52.49,",DA=PSOIEN,DR="20.6////"_PSOCLNC D ^DIE K DIE
;
D ALLERGY^PSOERUT3("LM",NMSPC,PSOIEN,+$$GET1^DIQ(52.49,PSOIEN,.05,"I"))
;
D SETDRUG^PSOERUT2("LM",NMSPC,PSOIEN,0)
;
D SETDIAGS^PSOERUT3("LM",NMSPC,PSOIEN)
;
S VALMCNT=LINE-1
S EDTYP="D"
; - Saving NORMAL video attributes to be reset later
I LINE>$G(LASTLINE) D
. F I=($G(LASTLINE)+1):1:LINE D SAVE^VALM10(I)
. S LASTLINE=LINE
D VIDEO^PSOERUT0()
;
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K @VALMAR,EDTYP
Q
;
EXPND ; -- expand code
Q
; ARY - array to store the output (pass by reference)
; TEXT - the text to convert into the array format
; DELIM - delimiter for text (default is space)
; MAXLEN - maximum length of each array items text, defaults to 80
TXT2ARY(ARY,TEXT,DELIM,MAXLEN) ;
N WORD,I,LCNT,LINETXT,S
S S=$S($D(DELIM):DELIM,1:" ")
I '$G(MAXLEN) S MAXLEN=80
S LCNT=1,LINETXT=""
F I=1:1:$L(TEXT,S) D
.S WORD=$P(TEXT,S,I)
.;PSO*7*635 - Begin parsing modications
.N TOTLEN,NUMLINES,STRT,ARYCNT,NLINE,J
.S TOTLEN=$L(WORD)
.I TOTLEN>MAXLEN D Q
..; if there was data in linetxt, file it and update the counter before continuing
..I $L(LINETXT) S ARY(LCNT)=LINETXT,LCNT=LCNT+1,LINETXT=""
..S NUMLINES=TOTLEN/MAXLEN+1
..S (STRT,ARYCNT)=1
..; loop through the long line and break it into sub-sections based on the maxlen
..F J=1:1:+$G(NUMLINES) D
...S NLINE=$E(WORD,STRT,MAXLEN*ARYCNT) Q:NLINE=""
...S ARY(LCNT)=NLINE,STRT=MAXLEN*ARYCNT+1,ARYCNT=ARYCNT+1,LCNT=LCNT+1
.I $L(LINETXT)+$L(S)+$L(WORD)>MAXLEN D Q
..S ARY(LCNT)=LINETXT
..S LCNT=LCNT+1,LINETXT=WORD
.I '$L(LINETXT) D Q
..; if the current word plus the next word are greater than the maxlength, set the current word and quit.
..I $L(WORD)+$L($P(TEXT,S,I+1))>MAXLEN D Q
...S ARY(LCNT)=WORD,LCNT=LCNT+1 Q
..S LINETXT=WORD Q
.; PSO*7*635 - End modifications
.S LINETXT=LINETXT_S_WORD
; if there is information left, set it into the array
I $L(LINETXT) S ARY(LCNT)=$G(LINETXT)
Q
DOSE ;displays dosing info for pending orders. called from psoorfi1
K II,UNITS S DS=1
I '$O(^PS(52.49,PSOIEN,21,0)) S LINE=LINE+1,LINETXT="" D ADDITEM^PSOERX1A(.LINETXT," (2) *Dosage:",,1,30) D SET^VALM10(LINE,LINETXT) S LINETXT="" G DOSEX
F I=0:0 S I=$O(^PS(52.49,PSOIEN,21,I)) Q:'I S DOSE=$G(^PS(52.49,PSOIEN,21,I,1)),DOSE1=$G(^(2)) D D DOSE1
.S II=$G(II)+1 K PSONEW("UNITS",II)
.S PSONEW("DOSE",II)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSONEW("UNITS",II)=$P(DOSE,"^",9),PSONEW("NOUN",II)=$P(DOSE,"^",5)
.S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
.S PSONEW("VERB",II)=$P(DOSE,"^",10),PSONEW("ROUTE",II)=$P(DOSE,"^",8)
.S ROUTE="" S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
.S PSONEW("SCHEDULE",II)=$P(DOSE,"^"),PSONEW("DURATION",II)=$P(DOSE,"^",2)
.S DOENT=$G(DOENT)+1 I $P(DOSE,"^",6)]"" S PSONEW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A")
.I 'PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" D
..S LINETXT="" S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," Verb: ",$G(PSONEW("VERB",II)),1,40)
..D SET^VALM10(LINE,LINETXT) S LINETXT=""
.S:$G(DS) LINE=LINE+1 D:II=1 ADDITEM^PSOERX1A(.LINETXT," (2)","",1,5)
DOSEX S PSONEW("ENT")=+$G(II) K DOSE,DOSE1,II,I,UNITS,ROUTE,DG
Q
DOSE1 ;
I $G(DS)=1 D ADDITEM^PSOERX1A(.LINETXT," *Dosage:","",4,30) D FMD G DU
S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," *Dosage:","",1,30) D FMD
DU ;
S PSODFN=$G(PATIEN)
I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") D
.S LINE=LINE+1,LINETXT="" D ADDITEM^PSOERX1A(.LINETXT," Oth. Lang. Dosage: ",$G(PSONEW("ODOSE",I)),1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
I PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" D
.S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," Verb: ",$G(PSONEW("VERB",II)),1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
.S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," Dispense Units: ",$S($E(PSONEW("DOSE ORDERED",II),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",II),1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
I PSONEW("NOUN",II)]"" D
.S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," Noun: ",PSONEW("NOUN",II),1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
I $G(ROUTE)]"" D
.S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," *Route: ",$G(ROUTE),1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," *Schedule: ",PSONEW("SCHEDULE",II),1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
I $G(PSONEW("DURATION",II))]"" D
.S PSONEW("DURATION",II)=$S($E(PSONEW("DURATION",II),1)'?.N:$E(PSONEW("DURATION",II),2,99)_$E(PSONEW("DURATION",II),1),1:PSONEW("DURATION",II))
.S TDUR=PSONEW("DURATION",II)_" ("_$S(PSONEW("DURATION",II)["M":"MINUTES",PSONEW("DURATION",II)["H":"HOURS",PSONEW("DURATION",II)["L":"MONTHS",PSONEW("DURATION",II)["W":"WEEKS",1:"DAYS")_")"
.S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," *Duration: ",TDUR,1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
I $G(PSONEW("CONJUNCTION",II))]"" D
.S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," *Conjunction: ",$S(PSONEW("CONJUNCTION",II)="T":"THEN",PSONEW("CONJUNCTION",II)="X":"EXCEPT",1:"AND"),1,50) D SET^VALM10(LINE,LINETXT) S LINETXT=""
Q
FMD ;
Q:$G(PSONEW("DOSE",II))']"" S MIG=PSONEW("DOSE",II)
I $E(MIG,1)=".",$G(PSONEW("DOSE ORDERED",II)) S MIG="0"_MIG
F SG=1:1:$L(MIG," ") D
.I $L(LINETXT_" "_$P(MIG," ",SG))>80 D Q
..S LINE=LINE+1 D ADDITEM^PSOERX1A(.LINETXT," ","",20,1)
..D ADDITEM^PSOERX1A(.LINETXT," ",$P(MIG," ",SG),$L(LINETXT),$L($P(MIG," ",SG))+1)
.D ADDITEM^PSOERX1A(.LINETXT," ",$P(MIG," ",SG),$L(LINETXT),$L($P(MIG," ",SG))+1)
D SET^VALM10(LINE,LINETXT) S LINETXT=""
I $G(UNITS)]"" D
.I $L(LINETXT_" ("_UNITS_")")>80 D Q
..S LINE=LINE+1,LINETXT=""
..D ADDITEM^PSOERX1A(.LINETXT," ","",20,1)
..D ADDITEM^PSOERX1A(.LINETXT," ("_UNITS_")",22,50)
..D SET^VALM10(LINE,LINETXT) S LINETXT=""
K DS,MIG,SG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXD1 8034 printed Dec 13, 2024@02:28:28 Page 2
PSOERXD1 ;ALB/BWF - eRx Drug display/actions ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,520,551,582,581,635,617,651,689,700,746,769**;DEC 1997;Build 26
+2 ;
EN ; -- main entry point for PSO ERX HOLDING QUEUE
+1 DO EN^VALM("PSO ERX DRUG VALIDATION")
+2 QUIT
+3 ;
LMHDR ; ListMan Header Code
+1 DO SHOW^VALM
DO HDR^PSOERXD1
+2 SET ORMXQ("??")="D HELP^VALM2,HDR^PSOERXD1"
+3 QUIT
+4 ;
HDR ; -- header code
+1 NEW AMATCH,VDRGIEN,VALUSER,VALDTTM,MATCH,HDR,EFFDATE
+2 SET AMATCH=$$GET1^DIQ(52.49,PSOIEN,1.4,"I")
SET VDRGIEN=$$GET1^DIQ(52.49,PSOIEN,3.2,"I")
+3 SET VALUSER=$$GET1^DIQ(52.49,PSOIEN,1.11,"E")
SET VALDTTM=$$GET1^DIQ(52.49,PSOIEN,1.12,"I")
+4 SET VALMHDR(1)="eRx Reference #: "_IOINHI_$$GET1^DIQ(52.49,PSOIEN,.01,"E")_IOINORM
+5 DO INSTR^VALM1("eRx Patient: "_IOINHI_$$GET1^DIQ(52.49,PSOIEN,.04,"E")_IOINORM,32,2)
+6 SET VALMHDR(2)="Date Written : "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.49,PSOIEN,5.9,"I")\1,"2Y")_IOINORM
+7 ; Have to use INSTR^VALM1 to reach the end of the line (due to Listman issues/bug with formatting)
+8 SET EFFDATE="Effective Date: "_IOINHI_$$FMTE^XLFDT($$GET1^DIQ(52.49,PSOIEN,6.3,"I"),"2Y")_IOINORM
+9 DO INSTR^VALM1(EFFDATE,29,3)
+10 SET MATCH=$SELECT(AMATCH=1:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VDRGIEN:"MANUALLY-MATCHED",1:"")
+11 IF VALUSER'=""
IF MATCH'=""
SET MATCH=MATCH_" | VALIDATED by "_$EXTRACT(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM,"2Y")
+12 IF MATCH=""
SET MATCH="NOT MATCHED"
+13 SET $EXTRACT(MATCH,81)=""
DO INSTR^VALM1("Status: "_IOINHI_MATCH_IOINORM,1,4)
+14 SET HDR=""
SET $EXTRACT(HDR,17)="ERX MED"
SET $EXTRACT(HDR,40)="|"
SET $EXTRACT(HDR,56)="VISTA MED"
+15 SET $EXTRACT(HDR,81)=""
DO INSTR^VALM1(IORVON_IOUON_HDR_IORVOFF_IOINORM,1,5)
+16 QUIT
+17 ;
INIT ;
+1 NEW I,LINE,REVLN,HIGHLN,UNDERLN,HIGUNDLN,DIE,DA,DR,NMSPC
+2 SET NMSPC="PSOERDR1"
KILL ^TMP(NMSPC,$JOB)
+3 ; - Resetting list to NORMAL video attributes
+4 DO RESET^PSOERUT0()
+5 SET LINE=1
+6 ;
+7 ; Routing (Window/Mail)
+8 IF $$GET1^DIQ(52.49,PSOIEN,20.4,"E")=""
Begin DoDot:1
+9 SET DIE="^PS(52.49,"
SET DA=PSOIEN
SET DR="20.4////M"
DO ^DIE
KILL DIE
End DoDot:1
+10 ;
+11 ; Clinic
+12 IF '$$GET1^DIQ(52.49,PSOIEN,20.6,"I")
IF $GET(PSOCLNC)
Begin DoDot:1
+13 SET DIE="^PS(52.49,"
SET DA=PSOIEN
SET DR="20.6////"_PSOCLNC
DO ^DIE
KILL DIE
End DoDot:1
+14 ;
+15 DO ALLERGY^PSOERUT3("LM",NMSPC,PSOIEN,+$$GET1^DIQ(52.49,PSOIEN,.05,"I"))
+16 ;
+17 DO SETDRUG^PSOERUT2("LM",NMSPC,PSOIEN,0)
+18 ;
+19 DO SETDIAGS^PSOERUT3("LM",NMSPC,PSOIEN)
+20 ;
+21 SET VALMCNT=LINE-1
+22 SET EDTYP="D"
+23 ; - Saving NORMAL video attributes to be reset later
+24 IF LINE>$GET(LASTLINE)
Begin DoDot:1
+25 FOR I=($GET(LASTLINE)+1):1:LINE
DO SAVE^VALM10(I)
+26 SET LASTLINE=LINE
End DoDot:1
+27 DO VIDEO^PSOERUT0()
+28 ;
+29 QUIT
+30 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL @VALMAR,EDTYP
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ; ARY - array to store the output (pass by reference)
+3 ; TEXT - the text to convert into the array format
+4 ; DELIM - delimiter for text (default is space)
+5 ; MAXLEN - maximum length of each array items text, defaults to 80
TXT2ARY(ARY,TEXT,DELIM,MAXLEN) ;
+1 NEW WORD,I,LCNT,LINETXT,S
+2 SET S=$SELECT($DATA(DELIM):DELIM,1:" ")
+3 IF '$GET(MAXLEN)
SET MAXLEN=80
+4 SET LCNT=1
SET LINETXT=""
+5 FOR I=1:1:$LENGTH(TEXT,S)
Begin DoDot:1
+6 SET WORD=$PIECE(TEXT,S,I)
+7 ;PSO*7*635 - Begin parsing modications
+8 NEW TOTLEN,NUMLINES,STRT,ARYCNT,NLINE,J
+9 SET TOTLEN=$LENGTH(WORD)
+10 IF TOTLEN>MAXLEN
Begin DoDot:2
+11 ; if there was data in linetxt, file it and update the counter before continuing
+12 IF $LENGTH(LINETXT)
SET ARY(LCNT)=LINETXT
SET LCNT=LCNT+1
SET LINETXT=""
+13 SET NUMLINES=TOTLEN/MAXLEN+1
+14 SET (STRT,ARYCNT)=1
+15 ; loop through the long line and break it into sub-sections based on the maxlen
+16 FOR J=1:1:+$GET(NUMLINES)
Begin DoDot:3
+17 SET NLINE=$EXTRACT(WORD,STRT,MAXLEN*ARYCNT)
if NLINE=""
QUIT
+18 SET ARY(LCNT)=NLINE
SET STRT=MAXLEN*ARYCNT+1
SET ARYCNT=ARYCNT+1
SET LCNT=LCNT+1
End DoDot:3
End DoDot:2
QUIT
+19 IF $LENGTH(LINETXT)+$LENGTH(S)+$LENGTH(WORD)>MAXLEN
Begin DoDot:2
+20 SET ARY(LCNT)=LINETXT
+21 SET LCNT=LCNT+1
SET LINETXT=WORD
End DoDot:2
QUIT
+22 IF '$LENGTH(LINETXT)
Begin DoDot:2
+23 ; if the current word plus the next word are greater than the maxlength, set the current word and quit.
+24 IF $LENGTH(WORD)+$LENGTH($PIECE(TEXT,S,I+1))>MAXLEN
Begin DoDot:3
+25 SET ARY(LCNT)=WORD
SET LCNT=LCNT+1
QUIT
End DoDot:3
QUIT
+26 SET LINETXT=WORD
QUIT
End DoDot:2
QUIT
+27 ; PSO*7*635 - End modifications
+28 SET LINETXT=LINETXT_S_WORD
End DoDot:1
+29 ; if there is information left, set it into the array
+30 IF $LENGTH(LINETXT)
SET ARY(LCNT)=$GET(LINETXT)
+31 QUIT
DOSE ;displays dosing info for pending orders. called from psoorfi1
+1 KILL II,UNITS
SET DS=1
+2 IF '$ORDER(^PS(52.49,PSOIEN,21,0))
SET LINE=LINE+1
SET LINETXT=""
DO ADDITEM^PSOERX1A(.LINETXT," (2) *Dosage:",,1,30)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
GOTO DOSEX
+3 FOR I=0:0
SET I=$ORDER(^PS(52.49,PSOIEN,21,I))
if 'I
QUIT
SET DOSE=$GET(^PS(52.49,PSOIEN,21,I,1))
SET DOSE1=$GET(^(2))
Begin DoDot:1
+4 SET II=$GET(II)+1
KILL PSONEW("UNITS",II)
+5 SET PSONEW("DOSE",II)=$PIECE(DOSE1,"^")
SET PSONEW("DOSE ORDERED",II)=$PIECE(DOSE1,"^",2)
SET PSONEW("UNITS",II)=$PIECE(DOSE,"^",9)
SET PSONEW("NOUN",II)=$PIECE(DOSE,"^",5)
+6 if $PIECE(DOSE,"^",9)
SET UNITS=$PIECE(^PS(50.607,$PIECE(DOSE,"^",9),0),"^")
+7 SET PSONEW("VERB",II)=$PIECE(DOSE,"^",10)
SET PSONEW("ROUTE",II)=$PIECE(DOSE,"^",8)
+8 SET ROUTE=""
if $PIECE(DOSE,"^",8)
SET ROUTE=$PIECE(^PS(51.2,$PIECE(DOSE,"^",8),0),"^")
+9 SET PSONEW("SCHEDULE",II)=$PIECE(DOSE,"^")
SET PSONEW("DURATION",II)=$PIECE(DOSE,"^",2)
+10 SET DOENT=$GET(DOENT)+1
IF $PIECE(DOSE,"^",6)]""
SET PSONEW("CONJUNCTION",II)=$SELECT($PIECE(DOSE,"^",6)="S":"T",$PIECE(DOSE,"^",6)="X":"X",1:"A")
+11 IF 'PSONEW("DOSE ORDERED",II)
IF $GET(PSONEW("VERB",II))]""
Begin DoDot:2
+12 SET LINETXT=""
SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," Verb: ",$GET(PSONEW("VERB",II)),1,40)
+13 DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:2
+14 if $GET(DS)
SET LINE=LINE+1
if II=1
DO ADDITEM^PSOERX1A(.LINETXT," (2)","",1,5)
End DoDot:1
DO DOSE1
DOSEX SET PSONEW("ENT")=+$GET(II)
KILL DOSE,DOSE1,II,I,UNITS,ROUTE,DG
+1 QUIT
DOSE1 ;
+1 IF $GET(DS)=1
DO ADDITEM^PSOERX1A(.LINETXT," *Dosage:","",4,30)
DO FMD
GOTO DU
+2 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," *Dosage:","",1,30)
DO FMD
DU ;
+1 SET PSODFN=$GET(PATIEN)
+2 IF 'PSONEW("DOSE ORDERED",I)
IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
Begin DoDot:1
+3 SET LINE=LINE+1
SET LINETXT=""
DO ADDITEM^PSOERX1A(.LINETXT," Oth. Lang. Dosage: ",$GET(PSONEW("ODOSE",I)),1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:1
+4 IF PSONEW("DOSE ORDERED",II)
IF $GET(PSONEW("VERB",II))]""
Begin DoDot:1
+5 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," Verb: ",$GET(PSONEW("VERB",II)),1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
+6 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," Dispense Units: ",$SELECT($EXTRACT(PSONEW("DOSE ORDERED",II),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",II),1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:1
+7 IF PSONEW("NOUN",II)]""
Begin DoDot:1
+8 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," Noun: ",PSONEW("NOUN",II),1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:1
+9 IF $GET(ROUTE)]""
Begin DoDot:1
+10 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," *Route: ",$GET(ROUTE),1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:1
+11 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," *Schedule: ",PSONEW("SCHEDULE",II),1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
+12 IF $GET(PSONEW("DURATION",II))]""
Begin DoDot:1
+13 SET PSONEW("DURATION",II)=$SELECT($EXTRACT(PSONEW("DURATION",II),1)'?.N:$EXTRACT(PSONEW("DURATION",II),2,99)_$EXTRACT(PSONEW("DURATION",II),1),1:PSONEW("DURATION",II))
+14 SET TDUR=PSONEW("DURATION",II)_" ("_$SELECT(PSONEW("DURATION",II)["M":"MINUTES",PSONEW("DURATION",II)["H":"HOURS",PSONEW("DURATION",II)["L":"MONTHS",PSONEW("DURATION",II)["W":"WEEKS",1:"DAYS")_")"
+15 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," *Duration: ",TDUR,1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:1
+16 IF $GET(PSONEW("CONJUNCTION",II))]""
Begin DoDot:1
+17 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," *Conjunction: ",$SELECT(PSONEW("CONJUNCTION",II)="T":"THEN",PSONEW("CONJUNCTION",II)="X":"EXCEPT",1:"AND"),1,50)
DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:1
+18 QUIT
FMD ;
+1 if $GET(PSONEW("DOSE",II))']""
QUIT
SET MIG=PSONEW("DOSE",II)
+2 IF $EXTRACT(MIG,1)="."
IF $GET(PSONEW("DOSE ORDERED",II))
SET MIG="0"_MIG
+3 FOR SG=1:1:$LENGTH(MIG," ")
Begin DoDot:1
+4 IF $LENGTH(LINETXT_" "_$PIECE(MIG," ",SG))>80
Begin DoDot:2
+5 SET LINE=LINE+1
DO ADDITEM^PSOERX1A(.LINETXT," ","",20,1)
+6 DO ADDITEM^PSOERX1A(.LINETXT," ",$PIECE(MIG," ",SG),$LENGTH(LINETXT),$LENGTH($PIECE(MIG," ",SG))+1)
End DoDot:2
QUIT
+7 DO ADDITEM^PSOERX1A(.LINETXT," ",$PIECE(MIG," ",SG),$LENGTH(LINETXT),$LENGTH($PIECE(MIG," ",SG))+1)
End DoDot:1
+8 DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
+9 IF $GET(UNITS)]""
Begin DoDot:1
+10 IF $LENGTH(LINETXT_" ("_UNITS_")")>80
Begin DoDot:2
+11 SET LINE=LINE+1
SET LINETXT=""
+12 DO ADDITEM^PSOERX1A(.LINETXT," ","",20,1)
+13 DO ADDITEM^PSOERX1A(.LINETXT," ("_UNITS_")",22,50)
+14 DO SET^VALM10(LINE,LINETXT)
SET LINETXT=""
End DoDot:2
QUIT
End DoDot:1
+15 KILL DS,MIG,SG
+16 QUIT
