BTIUMED1 ; SLC/JM - Active/Recent Med Objects Routine ;24-Sep-2013 14:41;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1006,1011,1012**;Jun 20, 1997;Build 45
;
; All routines here are part of the LIST entry point of TIULMED
;
ADD(TXT) ; Saves TXT in TARGET
S NEXTLINE=NEXTLINE+1
I TAB S TXT=" "_TXT
I TAB,HEADER S TXT=" "_TXT
S @TARGET@(NEXTLINE,0)=TXT
Q
ADDLNUM(TXT) ; Add text with Line Number added to front of string
S TAB=0
I HEADER D ADD($E(COUNT_") ",1,5)_TXT) I 1
E D ADD(TXT)
S TAB=1
Q
ADDL(TXT) ; Add with ADDLNUM on FIRST
I FIRST D I 1
.D ADDLNUM(TXT)
.S FIRST=0
E D ADD(TXT)
Q
ADDMED(XMODE,REC) ; if XMODE creates XSTR, if not add med to TARGET
N DATA,FIRST,XSUM,XCOUNT,TOPLINE,WSTATUS
S REC=$G(REC)
S FIRST=1
I XMODE S (XSUM,XCOUNT)=0,XSTR=""
E D
.S TOPLINE=NEXTLINE+1,DATA="",WSTATUS=0
.I $D(PHARM) D ADDP(20)
.D ADDP(2)
I TYPE="UD" D I 1 ; Unit Dose Meds
.I 'XMODE D
..I DETAILED D FLUSH S DATA="Give:"
..S DATA=DATA_" "
.I $$PL(6) D ADDP(6) I 1
.E I $$PL(7) D ADDP(7) I 1
.E D ADDM("SIG")
.D ADDM("MDR"),ADDM("SCH")
.I DETAILED D FLUSH
.D ADDM("SIO")
.I +REC D RECON
E I TYPE="OP" D I 1 ; Outpatient Meds
.I 'XMODE,DETAILED D
..I $$PL(12) D
...S DATA=DATA_" Qty:"
...D ADDP(12)
..I $$PL(11) D
...S DATA=$$STRIP(DATA_" for")
...D ADDP(11)
...S DATA=$$STRIP(DATA_" days")
..D WRAP
.I $$ML("SIG") D I 1
..I 'XMODE,DETAILED S DATA=$$STRIP(DATA_" Sig:")
..D ADDM("SIG")
.E D ADDM("SIO"),ADDM("MDR"),ADDM("SCH")
.D FLUSH
.I $P(NODE,U,9)="HOLD" D
..I $$PL(18) D
...S DATA="Reason for HOLD: "
...D ADDP(18)
...D FLUSH
..;D WRAP
.I CLININC>0 D
..I $$PL(19) D
...I CLININC=1 S DATA="Clinical Indication: "
...D ADDP(19)
...D FLUSH
.I $P($P(NODE,U),";")["R" D
..I $$PL(21) D
...S DATA="Provider: "
...D ADDP(21)
...D FLUSH
..I $D(PHARM) D
...I $$ML("FILL") D I 1
....S DATA=$$STRIP(DATA_" Fills:")
....D ADDM("FILL")
....D FLUSH
...I $$ML("FILLS") D I 1
....S DATA=$$STRIP(DATA_" Past Fills:")
....D ADDM("FILLS")
....D FLUSH
..I $$PL(31) D
...N PHM,DATA,RXNO,ORD,RR,SSNUM
...S PHM=$P($P(NODE,U,31),";",1)
...S DATA="Pharm: "_$$GET1^DIQ(9009033.9,PHM,.01)_" "_$$HLPHONE^HLFNC($$GET1^DIQ(9009033.9,PHM,2.1))
...D FLUSH
...S DATA=$$PADDR^APSPESG1(PHM)
...D FLUSH
...S RXNO=$P($P(NODE,U,31),";",2)
...Q:'+RXNO
...S DATA="Prov: "_$$GET1^DIQ(52,RXNO,4)
...D FLUSH
...S DATA="Trans: "_$$XMTDATE^BEHORXRT(RXNO)
...D FLUSH
...S ORD=$$GET1^DIQ(52,RXNO,39.3)
...Q:'+ORD
...S RR=$$VALUE^ORCSAVE2(+ORD,"SSRREQIEN")
...Q:'+RR
...S SSNUM=$$GET1^DIQ(9009033.91,RR,.1)
...S DATA="Number: "_SSNUM
...D FLUSH
.I +REC D RECON
E I TYPE="IV" D ; IV meds
.I DETAILED D FLUSH
.D ADDM("A")
.I $$ML("B") D
..I 'XMODE S DATA=$$STRIP(DATA_" in")
..D ADDM("B")
.D ADDP(3)
.I DETAILED D FLUSH
.D ADDM("SIO")
.D FLUSH
.I 'XMODE D
..N I
..F I=TOPLINE:1:NEXTLINE S @TARGET@(I,0)=$TR(@TARGET@(I,0),U," ")
I XMODE D I 1
.I XSTR="" S XSTR="_"
.E I $L(XSTR)>80 S XSTR=$E(XCOUNT_"_"_XSUM_"_"_XSTR,1,80)
E D
.D FLUSH
.S WSTATUS=1
.D ADDP(9)
.S WSTATUS=0
.I DETAILED D
..;D ADDDATE(TOPLINE,$S(MEDTYPE=OUTPTYPE:"Issu",1:"Strt"),15)
..I MEDTYPE=OUTPTYPE D I 1
...N I
...I TOPLINE=NEXTLINE S I=TOPLINE+1
...E I $L(@TARGET@(TOPLINE+1,0))<48 S I=TOPLINE+1
...E S I=TOPLINE+2
...F Q:(I'>NEXTLINE) D ADD(" ")
...I $P(NODE,U,5)="" S @TARGET@(I,0)=$E(@TARGET@(I,0)_SPACE60,1,47)
...E S @TARGET@(I,0)=$E(@TARGET@(I,0)_SPACE60,1,47)_"Refills: "_+$P(NODE,U,5)
...D ADDDATE(TOPLINE,"Issue",15)
...D ADDDATE(TOPLINE+1,"Last",10)
...D ADDDATE(TOPLINE+2,"Expr",4)
..E D
...D ADDDATE(TOPLINE+1,"Stop",4)
Q
FDT(PNUM) ;Returns formatted date from piece number
N X,Y
S Y=$P(NODE,U,PNUM)
S X=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_$E($E(Y,1,3)+1700,3,4)
Q X
ADDDATE(LINENUM,TXT,PNUM) ;Add date to TARGET
I $$PL(PNUM) D
.F Q:(LINENUM'>NEXTLINE) D ADD(" ")
.S @TARGET@(LINENUM,0)=$E(@TARGET@(LINENUM,0)_SPACE60,1,60)_TXT_":"_$$FDT(PNUM)
Q
XSUMS(STR,NOADD) ; XSUMs a string
N IDX,LEN
S LEN=$L(STR) I LEN'>0 Q
I '$G(NOADD),$L(XSTR)<99 S XSTR=XSTR_STR
F IDX=1:1:LEN S XCOUNT=XCOUNT+1,XSUM=XSUM+($A(STR,IDX)*XCOUNT)
Q
WRAP ; Wraps DATA to the output
I XMODE Q
N IDX,LEN,MAX,DATA1,DONE
S DONE=0
F Q:DONE D
.I WSTATUS S MAX=13
.E D
..I FIRST S MAX=41
..E S MAX=39
..I 'HEADER S MAX=MAX+5
..I 'DETAILED S MAX=MAX+13
.S LEN=$L(DATA)
.I 'WSTATUS,LEN<MAX S DONE=1 Q
.I LEN<MAX S IDX=LEN
.E F IDX=MAX:-1:2 Q:$E(DATA,IDX)=" "
.I IDX<3 S IDX=MAX-1
.S DATA1=$$STRIP($E(DATA,1,IDX))
.I WSTATUS D I 1
..S @TARGET@(TOPLINE,0)=$E(@TARGET@(TOPLINE,0)_SPACE60,1,LLEN)_DATA1
.E D ADDL(DATA1)
.S DATA=$$STRIP($E(DATA,IDX+1,999))
.I WSTATUS D
..S DONE=1,WSTATUS=0
..I $L(DATA)>0 D
...I TOPLINE'<NEXTLINE D ADD(" ")
...S @TARGET@(TOPLINE+1,0)=$E(@TARGET@(TOPLINE+1,0)_SPACE60,1,LLEN)_DATA
...S DATA=""
Q
STRIP(X) ; Removes Leading and Trialing Spaces
F Q:$E(X)'=" " S X=$E(X,2,999)
F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1)
Q X
ADDP(PNUM) ; Adds or XSUMs a piece of NODE
I XMODE D I 1
.D XSUMS(PNUM,1)
.D XSUMS($P(NODE,U,PNUM))
E D
.N VALUE
.S VALUE=$P(NODE,U,PNUM)
.I PNUM=9,VALUE="SUSPENDED" S VALUE="ACTIVE (S)"
.S DATA=$$STRIP(DATA_" "_VALUE)
.D WRAP
Q
ADDM(SUB,FORCE) ; Adds or XSUMs Multiple
N IDX
S IDX=0
I XMODE D I 1
.D XSUMS(SUB,1)
.F S IDX=$O(^TMP("PS",$J,INDEX,SUB,IDX)) Q:IDX="" D
..D XSUMS(^TMP("PS",$J,INDEX,SUB,IDX,0))
E D
.I $G(FORCE),DETAILED D FLUSH
.F S IDX=$O(^TMP("PS",$J,INDEX,SUB,IDX)) Q:IDX="" D
..S DATA=$$STRIP(DATA_" "_^TMP("PS",$J,INDEX,SUB,IDX,0))
..D WRAP
Q
FLUSH ; Flush the DATA buffer
I 'XMODE,DATA'="" D
.D WRAP
.I DATA'="" D ADDL(DATA) S DATA=""
Q
PL(PNUM) ;Retuns length of peice
Q $L($P(NODE,U,PNUM))
ML(SUB) ;Returns true if multiple exists and contains data
N IDX,ML
S (IDX,ML)=0
F S IDX=$O(^TMP("PS",$J,INDEX,SUB,IDX)) Q:(IDX="")!ML D
.I $L(^TMP("PS",$J,INDEX,SUB,IDX,0)) S ML=1
Q ML
ADDTITLE(DAYS) ;Adds a title line indicating which meds are in the list
N MSG,ALL,SUP,SUPFX
I ACTVONLY<2 S MSG="Active"
E S MSG=""
I '+ACTVONLY S MSG=MSG_" and "
I ACTVONLY=2 S MSG=MSG_"Expired in last "_DAYS_" days"
I ACTVONLY=4 S MSG=MSG_"Medications on hold"
S ALL=ALLMEDS
I ALL=0 D
.I ISINP S ALL=2
.E S ALL=3
S MSG=MSG_" "
I ALL'=3 S MSG=MSG_"Inpatient"
I ALL=1 S MSG=MSG_" and "
I ALL'=2 S MSG=MSG_"Outpatient"
S MSG=MSG_" Medications"
I SUPPLIES S SUPFX="in"
E S SUPFX="ex"
S SUPFX="("_SUPFX_"cluding Supplies):"
I $L(MSG)>51 D I 1
.D ADD(MSG)
.D ADD(SUPFX)
E D
.S MSG=MSG_" "_SUPFX
.D ADD(MSG)
D ADD(" ")
Q
WARNING ;Inserts warning about CLASSORT if needed
I CLASSORT D
.N MSG
.D ADD("* * WARNING * * Sorting by drug class may not be accurate!")
.D ADD("Medications belonging to multiple drug classes will only be listed")
.S MSG="under a single drug class."
.I UNKNOWNS S MSG=MSG_" In addition, the system is not able to"
.D ADD(MSG)
.I UNKNOWNS D ADD("determine the drug class of some medications.")
Q
RECON ;Check for reconciliation
N MED,REC,IEN,AIEN,WHEN,BY,NVAMED,RX
S RX=+NODE
S TYP=$P($P(NODE,U),";",2)
S TYP=$S(TYP="O":"X",TYP="I":"U",1:"")
S NVAMED=$P($P(NODE,U),";")
S NVAMED=$E(NVAMED,$L(NVAMED))
I NVAMED="N" S TYP="N"
S REC=""
S REC=$O(^BEHOCIR("G",TYP,RX,REC),-1) Q:REC="" D
.S IEN="" S IEN=$O(^BEHOCIR("G",TYP,RX,REC,IEN),-1) Q:IEN="" D
..S AIEN=IEN_","_REC_","
..S WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
..S BY=$$GET1^DIQ(90461.632,AIEN,.02)
..S DATA="Reconciled on: "_WHEN_" by "_BY
..D FLUSH
Q
BTIUMED1 ; SLC/JM - Active/Recent Med Objects Routine ;24-Sep-2013 14:41;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1006,1011,1012**;Jun 20, 1997;Build 45
+2 ;
+3 ; All routines here are part of the LIST entry point of TIULMED
+4 ;
ADD(TXT) ; Saves TXT in TARGET
+1 SET NEXTLINE=NEXTLINE+1
+2 IF TAB
SET TXT=" "_TXT
+3 IF TAB
IF HEADER
SET TXT=" "_TXT
+4 SET @TARGET@(NEXTLINE,0)=TXT
+5 QUIT
ADDLNUM(TXT) ; Add text with Line Number added to front of string
+1 SET TAB=0
+2 IF HEADER
DO ADD($EXTRACT(COUNT_") ",1,5)_TXT)
IF 1
+3 IF '$TEST
DO ADD(TXT)
+4 SET TAB=1
+5 QUIT
ADDL(TXT) ; Add with ADDLNUM on FIRST
+1 IF FIRST
Begin DoDot:1
+2 DO ADDLNUM(TXT)
+3 SET FIRST=0
End DoDot:1
IF 1
+4 IF '$TEST
DO ADD(TXT)
+5 QUIT
ADDMED(XMODE,REC) ; if XMODE creates XSTR, if not add med to TARGET
+1 NEW DATA,FIRST,XSUM,XCOUNT,TOPLINE,WSTATUS
+2 SET REC=$GET(REC)
+3 SET FIRST=1
+4 IF XMODE
SET (XSUM,XCOUNT)=0
SET XSTR=""
+5 IF '$TEST
Begin DoDot:1
+6 SET TOPLINE=NEXTLINE+1
SET DATA=""
SET WSTATUS=0
+7 IF $DATA(PHARM)
DO ADDP(20)
+8 DO ADDP(2)
End DoDot:1
+9 ; Unit Dose Meds
IF TYPE="UD"
Begin DoDot:1
+10 IF 'XMODE
Begin DoDot:2
+11 IF DETAILED
DO FLUSH
SET DATA="Give:"
+12 SET DATA=DATA_" "
End DoDot:2
+13 IF $$PL(6)
DO ADDP(6)
IF 1
+14 IF '$TEST
IF $$PL(7)
DO ADDP(7)
IF 1
+15 IF '$TEST
DO ADDM("SIG")
+16 DO ADDM("MDR")
DO ADDM("SCH")
+17 IF DETAILED
DO FLUSH
+18 DO ADDM("SIO")
+19 IF +REC
DO RECON
End DoDot:1
IF 1
+20 ; Outpatient Meds
IF '$TEST
IF TYPE="OP"
Begin DoDot:1
+21 IF 'XMODE
IF DETAILED
Begin DoDot:2
+22 IF $$PL(12)
Begin DoDot:3
+23 SET DATA=DATA_" Qty:"
+24 DO ADDP(12)
End DoDot:3
+25 IF $$PL(11)
Begin DoDot:3
+26 SET DATA=$$STRIP(DATA_" for")
+27 DO ADDP(11)
+28 SET DATA=$$STRIP(DATA_" days")
End DoDot:3
+29 DO WRAP
End DoDot:2
+30 IF $$ML("SIG")
Begin DoDot:2
+31 IF 'XMODE
IF DETAILED
SET DATA=$$STRIP(DATA_" Sig:")
+32 DO ADDM("SIG")
End DoDot:2
IF 1
+33 IF '$TEST
DO ADDM("SIO")
DO ADDM("MDR")
DO ADDM("SCH")
+34 DO FLUSH
+35 IF $PIECE(NODE,U,9)="HOLD"
Begin DoDot:2
+36 IF $$PL(18)
Begin DoDot:3
+37 SET DATA="Reason for HOLD: "
+38 DO ADDP(18)
+39 DO FLUSH
End DoDot:3
+40 ;D WRAP
End DoDot:2
+41 IF CLININC>0
Begin DoDot:2
+42 IF $$PL(19)
Begin DoDot:3
+43 IF CLININC=1
SET DATA="Clinical Indication: "
+44 DO ADDP(19)
+45 DO FLUSH
End DoDot:3
End DoDot:2
+46 IF $PIECE($PIECE(NODE,U),";")["R"
Begin DoDot:2
+47 IF $$PL(21)
Begin DoDot:3
+48 SET DATA="Provider: "
+49 DO ADDP(21)
+50 DO FLUSH
End DoDot:3
+51 IF $DATA(PHARM)
Begin DoDot:3
+52 IF $$ML("FILL")
Begin DoDot:4
+53 SET DATA=$$STRIP(DATA_" Fills:")
+54 DO ADDM("FILL")
+55 DO FLUSH
End DoDot:4
IF 1
+56 IF $$ML("FILLS")
Begin DoDot:4
+57 SET DATA=$$STRIP(DATA_" Past Fills:")
+58 DO ADDM("FILLS")
+59 DO FLUSH
End DoDot:4
IF 1
End DoDot:3
+60 IF $$PL(31)
Begin DoDot:3
+61 NEW PHM,DATA,RXNO,ORD,RR,SSNUM
+62 SET PHM=$PIECE($PIECE(NODE,U,31),";",1)
+63 SET DATA="Pharm: "_$$GET1^DIQ(9009033.9,PHM,.01)_" "_$$HLPHONE^HLFNC($$GET1^DIQ(9009033.9,PHM,2.1))
+64 DO FLUSH
+65 SET DATA=$$PADDR^APSPESG1(PHM)
+66 DO FLUSH
+67 SET RXNO=$PIECE($PIECE(NODE,U,31),";",2)
+68 IF '+RXNO
QUIT
+69 SET DATA="Prov: "_$$GET1^DIQ(52,RXNO,4)
+70 DO FLUSH
+71 SET DATA="Trans: "_$$XMTDATE^BEHORXRT(RXNO)
+72 DO FLUSH
+73 SET ORD=$$GET1^DIQ(52,RXNO,39.3)
+74 IF '+ORD
QUIT
+75 SET RR=$$VALUE^ORCSAVE2(+ORD,"SSRREQIEN")
+76 IF '+RR
QUIT
+77 SET SSNUM=$$GET1^DIQ(9009033.91,RR,.1)
+78 SET DATA="Number: "_SSNUM
+79 DO FLUSH
End DoDot:3
End DoDot:2
+80 IF +REC
DO RECON
End DoDot:1
IF 1
+81 ; IV meds
IF '$TEST
IF TYPE="IV"
Begin DoDot:1
+82 IF DETAILED
DO FLUSH
+83 DO ADDM("A")
+84 IF $$ML("B")
Begin DoDot:2
+85 IF 'XMODE
SET DATA=$$STRIP(DATA_" in")
+86 DO ADDM("B")
End DoDot:2
+87 DO ADDP(3)
+88 IF DETAILED
DO FLUSH
+89 DO ADDM("SIO")
+90 DO FLUSH
+91 IF 'XMODE
Begin DoDot:2
+92 NEW I
+93 FOR I=TOPLINE:1:NEXTLINE
SET @TARGET@(I,0)=$TRANSLATE(@TARGET@(I,0),U," ")
End DoDot:2
End DoDot:1
+94 IF XMODE
Begin DoDot:1
+95 IF XSTR=""
SET XSTR="_"
+96 IF '$TEST
IF $LENGTH(XSTR)>80
SET XSTR=$EXTRACT(XCOUNT_"_"_XSUM_"_"_XSTR,1,80)
End DoDot:1
IF 1
+97 IF '$TEST
Begin DoDot:1
+98 DO FLUSH
+99 SET WSTATUS=1
+100 DO ADDP(9)
+101 SET WSTATUS=0
+102 IF DETAILED
Begin DoDot:2
+103 ;D ADDDATE(TOPLINE,$S(MEDTYPE=OUTPTYPE:"Issu",1:"Strt"),15)
+104 IF MEDTYPE=OUTPTYPE
Begin DoDot:3
+105 NEW I
+106 IF TOPLINE=NEXTLINE
SET I=TOPLINE+1
+107 IF '$TEST
IF $LENGTH(@TARGET@(TOPLINE+1,0))<48
SET I=TOPLINE+1
+108 IF '$TEST
SET I=TOPLINE+2
+109 FOR
IF (I'>NEXTLINE)
QUIT
DO ADD(" ")
+110 IF $PIECE(NODE,U,5)=""
SET @TARGET@(I,0)=$EXTRACT(@TARGET@(I,0)_SPACE60,1,47)
+111 IF '$TEST
SET @TARGET@(I,0)=$EXTRACT(@TARGET@(I,0)_SPACE60,1,47)_"Refills: "_+$PIECE(NODE,U,5)
+112 DO ADDDATE(TOPLINE,"Issue",15)
+113 DO ADDDATE(TOPLINE+1,"Last",10)
+114 DO ADDDATE(TOPLINE+2,"Expr",4)
End DoDot:3
IF 1
+115 IF '$TEST
Begin DoDot:3
+116 DO ADDDATE(TOPLINE+1,"Stop",4)
End DoDot:3
End DoDot:2
End DoDot:1
+117 QUIT
FDT(PNUM) ;Returns formatted date from piece number
+1 NEW X,Y
+2 SET Y=$PIECE(NODE,U,PNUM)
+3 SET X=$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_$EXTRACT($EXTRACT(Y,1,3)+1700,3,4)
+4 QUIT X
ADDDATE(LINENUM,TXT,PNUM) ;Add date to TARGET
+1 IF $$PL(PNUM)
Begin DoDot:1
+2 FOR
IF (LINENUM'>NEXTLINE)
QUIT
DO ADD(" ")
+3 SET @TARGET@(LINENUM,0)=$EXTRACT(@TARGET@(LINENUM,0)_SPACE60,1,60)_TXT_":"_$$FDT(PNUM)
End DoDot:1
+4 QUIT
XSUMS(STR,NOADD) ; XSUMs a string
+1 NEW IDX,LEN
+2 SET LEN=$LENGTH(STR)
IF LEN'>0
QUIT
+3 IF '$GET(NOADD)
IF $LENGTH(XSTR)<99
SET XSTR=XSTR_STR
+4 FOR IDX=1:1:LEN
SET XCOUNT=XCOUNT+1
SET XSUM=XSUM+($ASCII(STR,IDX)*XCOUNT)
+5 QUIT
WRAP ; Wraps DATA to the output
+1 IF XMODE
QUIT
+2 NEW IDX,LEN,MAX,DATA1,DONE
+3 SET DONE=0
+4 FOR
IF DONE
QUIT
Begin DoDot:1
+5 IF WSTATUS
SET MAX=13
+6 IF '$TEST
Begin DoDot:2
+7 IF FIRST
SET MAX=41
+8 IF '$TEST
SET MAX=39
+9 IF 'HEADER
SET MAX=MAX+5
+10 IF 'DETAILED
SET MAX=MAX+13
End DoDot:2
+11 SET LEN=$LENGTH(DATA)
+12 IF 'WSTATUS
IF LEN<MAX
SET DONE=1
QUIT
+13 IF LEN<MAX
SET IDX=LEN
+14 IF '$TEST
FOR IDX=MAX:-1:2
IF $EXTRACT(DATA,IDX)=" "
QUIT
+15 IF IDX<3
SET IDX=MAX-1
+16 SET DATA1=$$STRIP($EXTRACT(DATA,1,IDX))
+17 IF WSTATUS
Begin DoDot:2
+18 SET @TARGET@(TOPLINE,0)=$EXTRACT(@TARGET@(TOPLINE,0)_SPACE60,1,LLEN)_DATA1
End DoDot:2
IF 1
+19 IF '$TEST
DO ADDL(DATA1)
+20 SET DATA=$$STRIP($EXTRACT(DATA,IDX+1,999))
+21 IF WSTATUS
Begin DoDot:2
+22 SET DONE=1
SET WSTATUS=0
+23 IF $LENGTH(DATA)>0
Begin DoDot:3
+24 IF TOPLINE'<NEXTLINE
DO ADD(" ")
+25 SET @TARGET@(TOPLINE+1,0)=$EXTRACT(@TARGET@(TOPLINE+1,0)_SPACE60,1,LLEN)_DATA
+26 SET DATA=""
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
STRIP(X) ; Removes Leading and Trialing Spaces
+1 FOR
IF $EXTRACT(X)'=" "
QUIT
SET X=$EXTRACT(X,2,999)
+2 FOR
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+3 QUIT X
ADDP(PNUM) ; Adds or XSUMs a piece of NODE
+1 IF XMODE
Begin DoDot:1
+2 DO XSUMS(PNUM,1)
+3 DO XSUMS($PIECE(NODE,U,PNUM))
End DoDot:1
IF 1
+4 IF '$TEST
Begin DoDot:1
+5 NEW VALUE
+6 SET VALUE=$PIECE(NODE,U,PNUM)
+7 IF PNUM=9
IF VALUE="SUSPENDED"
SET VALUE="ACTIVE (S)"
+8 SET DATA=$$STRIP(DATA_" "_VALUE)
+9 DO WRAP
End DoDot:1
+10 QUIT
ADDM(SUB,FORCE) ; Adds or XSUMs Multiple
+1 NEW IDX
+2 SET IDX=0
+3 IF XMODE
Begin DoDot:1
+4 DO XSUMS(SUB,1)
+5 FOR
SET IDX=$ORDER(^TMP("PS",$JOB,INDEX,SUB,IDX))
IF IDX=""
QUIT
Begin DoDot:2
+6 DO XSUMS(^TMP("PS",$JOB,INDEX,SUB,IDX,0))
End DoDot:2
End DoDot:1
IF 1
+7 IF '$TEST
Begin DoDot:1
+8 IF $GET(FORCE)
IF DETAILED
DO FLUSH
+9 FOR
SET IDX=$ORDER(^TMP("PS",$JOB,INDEX,SUB,IDX))
IF IDX=""
QUIT
Begin DoDot:2
+10 SET DATA=$$STRIP(DATA_" "_^TMP("PS",$JOB,INDEX,SUB,IDX,0))
+11 DO WRAP
End DoDot:2
End DoDot:1
+12 QUIT
FLUSH ; Flush the DATA buffer
+1 IF 'XMODE
IF DATA'=""
Begin DoDot:1
+2 DO WRAP
+3 IF DATA'=""
DO ADDL(DATA)
SET DATA=""
End DoDot:1
+4 QUIT
PL(PNUM) ;Retuns length of peice
+1 QUIT $LENGTH($PIECE(NODE,U,PNUM))
ML(SUB) ;Returns true if multiple exists and contains data
+1 NEW IDX,ML
+2 SET (IDX,ML)=0
+3 FOR
SET IDX=$ORDER(^TMP("PS",$JOB,INDEX,SUB,IDX))
IF (IDX="")!ML
QUIT
Begin DoDot:1
+4 IF $LENGTH(^TMP("PS",$JOB,INDEX,SUB,IDX,0))
SET ML=1
End DoDot:1
+5 QUIT ML
ADDTITLE(DAYS) ;Adds a title line indicating which meds are in the list
+1 NEW MSG,ALL,SUP,SUPFX
+2 IF ACTVONLY<2
SET MSG="Active"
+3 IF '$TEST
SET MSG=""
+4 IF '+ACTVONLY
SET MSG=MSG_" and "
+5 IF ACTVONLY=2
SET MSG=MSG_"Expired in last "_DAYS_" days"
+6 IF ACTVONLY=4
SET MSG=MSG_"Medications on hold"
+7 SET ALL=ALLMEDS
+8 IF ALL=0
Begin DoDot:1
+9 IF ISINP
SET ALL=2
+10 IF '$TEST
SET ALL=3
End DoDot:1
+11 SET MSG=MSG_" "
+12 IF ALL'=3
SET MSG=MSG_"Inpatient"
+13 IF ALL=1
SET MSG=MSG_" and "
+14 IF ALL'=2
SET MSG=MSG_"Outpatient"
+15 SET MSG=MSG_" Medications"
+16 IF SUPPLIES
SET SUPFX="in"
+17 IF '$TEST
SET SUPFX="ex"
+18 SET SUPFX="("_SUPFX_"cluding Supplies):"
+19 IF $LENGTH(MSG)>51
Begin DoDot:1
+20 DO ADD(MSG)
+21 DO ADD(SUPFX)
End DoDot:1
IF 1
+22 IF '$TEST
Begin DoDot:1
+23 SET MSG=MSG_" "_SUPFX
+24 DO ADD(MSG)
End DoDot:1
+25 DO ADD(" ")
+26 QUIT
WARNING ;Inserts warning about CLASSORT if needed
+1 IF CLASSORT
Begin DoDot:1
+2 NEW MSG
+3 DO ADD("* * WARNING * * Sorting by drug class may not be accurate!")
+4 DO ADD("Medications belonging to multiple drug classes will only be listed")
+5 SET MSG="under a single drug class."
+6 IF UNKNOWNS
SET MSG=MSG_" In addition, the system is not able to"
+7 DO ADD(MSG)
+8 IF UNKNOWNS
DO ADD("determine the drug class of some medications.")
End DoDot:1
+9 QUIT
RECON ;Check for reconciliation
+1 NEW MED,REC,IEN,AIEN,WHEN,BY,NVAMED,RX
+2 SET RX=+NODE
+3 SET TYP=$PIECE($PIECE(NODE,U),";",2)
+4 SET TYP=$SELECT(TYP="O":"X",TYP="I":"U",1:"")
+5 SET NVAMED=$PIECE($PIECE(NODE,U),";")
+6 SET NVAMED=$EXTRACT(NVAMED,$LENGTH(NVAMED))
+7 IF NVAMED="N"
SET TYP="N"
+8 SET REC=""
+9 SET REC=$ORDER(^BEHOCIR("G",TYP,RX,REC),-1)
IF REC=""
QUIT
Begin DoDot:1
+10 SET IEN=""
SET IEN=$ORDER(^BEHOCIR("G",TYP,RX,REC,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:2
+11 SET AIEN=IEN_","_REC_","
+12 SET WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
+13 SET BY=$$GET1^DIQ(90461.632,AIEN,.02)
+14 SET DATA="Reconciled on: "_WHEN_" by "_BY
+15 DO FLUSH
End DoDot:2
End DoDot:1
+16 QUIT
