TIUMOBJ ;XAN/AJB - MEDICATION OBJECT ;Aug 02, 2024@13:51:30
;;1.0;TEXT INTEGRATION UTILITIES;**365**;Jun 20, 1997;Build 1
;
; Reference to ^DIM in ICR #10016
; Reference to ^DPT( in ICR #10035
; Reference to PEN^PSO5241 in ICR #4821
; Reference to RX^PSO52API in ICR #4820
; Reference to OCL^PSOORRL in ICR #2400
; Reference to DRGIEN^PSS50P7 in ICR #4662
; Reference to *^PSS55 in ICR #4826
; Reference to *^XLFDT in ICR #10103
; Reference to *^XLFSTR in ICR #10104
;
; Required Parameter
; DFN Patient IEN
;
; Optional Parameters
; TARGET Return Location of data [default "OUTPUT"]
; Global TARGET must be ^TMP with at least one subscript
; A (active) 0 Active and recently expired meds [default]
; 1 Active meds only
; 2 Recently expired meds only
; D (detailed) 0 Standard med info [default]
; 1 Detailed med info
; M (meds) 0 Inpatient or Outpatient meds only, based on patient status [default]
; 1 Inpatient, outpatient & clinic meds
; 2/"I" Inpatient meds only
; 3/"O" Outpatient meds only
; 4/"C" Clinic meds only
; 5/"CI" Clinic and inpatient meds only
; 6/"CI" Clinic and outpatient meds only
; O (onelist) 0 Separates based on status [default]
; 1 Combines meds into one list per type
; SC (sort by class) 0 Sort meds alphabetically [default]
; 1 Sort by class, alphabetically
; 2 Sort by class with class in header
; SU (supplies) 0 Exclude supplies
; 1 Include supplies [default]
; Global Variable
; TIUDATE # of days to search from today [Med Reconciliation TIU*1.0*238 & PSO*7.0*294]
;
Q
LIST(DFN,TARGET,A,D,M,O,SC,SU) ;
; validate target, default to OUTPUT if needed
N P,X S DFN=+$G(DFN),TARGET=$G(TARGET,"OUTPUT"),TARGET=$S(TARGET[""""""!(TARGET[U&(TARGET'["^TMP(")):"OUTPUT",1:TARGET)
; DIM checks syntax, ensures valid TARGET
S X="S TEST="_TARGET D ^DIM S TARGET=$S('$D(X):"OUTPUT",1:TARGET)
; validate patient
I 'DFN!(DFN&('$D(^DPT(DFN)))) D ADD(.TARGET,$S('DFN:"No Patient ID",1:"Patient DFN invalid")) Q "~@"_$NA(@TARGET)
K @TARGET,^TMP("PS",$J)
; verify/set routine parameters in P(parameter)
F X="A","D","M","O","SC","SU" D
. S:X="A" A=$S(+$G(A)'<0&(+$G(A)<3):+$G(A),1:0)
. S:X="D" D=$S(+$G(D)'<0&(+$G(D)<2):+$G(D),1:0)
. S:X="M" M=$$UP($G(M)),M=$S(M="I":2,M="O":3,M="C":4,M="CI"!(M="IC"):5,M="CO"!(M="OC"):6,+$G(M)'<0&(+$G(M)<7):+$G(M),1:0)
. S:X="O" O=$S(+$G(O)'<0&(+$G(O)<2):+$G(O),1:0)
. S:X="SC" SC=$S(+$G(SC)'<0&(+$G(SC)<3):+$G(SC),1:0)
. S:X="SU" SU=$S($G(SU)="":1,+$G(SU)=0:0,1:1)
. S P(X)=@(X) K @(X) K:X="SU" X
; additional parameters/data
S P("AS")="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^ACTIVE/PARKED^"
S P("PS")="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
; sort order of inpatient/outpatient determined by patient status
S P("INP")=($G(^DPT(DFN,.1))'=""),P("SORT","I")=$S(P("INP"):2,1:3),P("SORT","O")=$S(P("INP"):3,1:2)
; flag for any drug with unknown class, evaluated in TITLE output
S P("UNK")=0
; variables left after external calls
N %H,BDT1,D0,DILOCKTM,DIQ2,DISYS,DRG,GP,IEN,LSTDS,LSTFD,LSTRD,ND2P5,PSSTMP2,RNWDT,SG
; get med data
D OCL^PSOORRL(DFN,$S('$G(TIUDATE):"",1:$$FMADD^XLFDT(DT,-$G(TIUDATE)))) G EX:'$D(^TMP("PS",$J))
N INDEX,MEDS,OCL M OCL=^TMP("PS",$J) K ^TMP("PS",$J)
S INDEX=0 F S INDEX=$O(OCL(INDEX)) Q:'INDEX D
. N MED S MED("NAME")=$TR($P(OCL(INDEX,0),U,2),"""","") Q:MED("NAME")=""
. ; TIU*238 & PSO*7.0*294 (Med Reconciliation)
. Q:$P(OCL(INDEX,0),U,9)["DISCONTINUED"&($G(TIUDATE))
. S:$P(OCL(INDEX,0),U,9)="ACTIVE/SUSP" $P(OCL(INDEX,0),U,9)="ACTIVE (S)"
. S MED("STATUS")=$P(OCL(INDEX,0),U,9)
. S MED("ORDER #")=+OCL(INDEX,0)
. S MED("CLINIC")=($G(OCL(INDEX,"CLINIC",0))>0)
. S MED("FILE")=$TR($P(OCL(INDEX,0),U),MED("ORDER #"),"")
. S MED("TYPE")=$P(MED("FILE"),";",2) Q:MED("TYPE")=""
. ; sort order: clinic=1, in/outpatient (based on patient status)=2/3, 4=Non-VA Meds
. S MED("SORT")=$S(MED("CLINIC"):1,MED("FILE")="N;O":4,MED("TYPE")="I":P("SORT","I"),MED("TYPE")="O":P("SORT","O"))
. ; sort=type_status
. S MED("SORT")=MED("SORT")_$S(P("O")!(P("AS")[MED("STATUS")):1,P("PS")[MED("STATUS"):2,1:3)
. ; add prefix if needed
. S:MED("FILE")="N;O" $P(OCL(INDEX,0),U,2)="Non-VA "_$P(OCL(INDEX,0),U,2)
. ; all active/pending inactive
. Q:$S('P("A"):0,P("A")=1&(P("AS")'[MED("STATUS")&(P("PS")'[MED("STATUS"))):1,P("A")=2&(P("AS")[MED("STATUS")!(P("PS")[MED("STATUS"))):1,1:0)
. ; in/outpatient all inpatient outpatient
. Q:$S(P("M")=0:$S(MED("CLINIC"):1,P("SORT",MED("TYPE"))=2:0,1:1),P("M")=1:0,P("M")=2:$S(MED("CLINIC"):1,MED("TYPE")="I":0,1:1),P("M")=3:$S(MED("CLINIC"):1,MED("TYPE")="O":0,1:1),1:0)
. ; clinic meds & inpatient & outpatient
. Q:$S(P("M")'<4:$S(MED("CLINIC"):0,P("M")=5:$S(MED("TYPE")="I":0,1:1),P("M")=6:$S(MED("TYPE")="O":0,1:1),1:1),1:0)
. ; get med class, needed for sorting by class or to exclude supplies
. I P("SC")!('P("SU")) D CLASS(.MED,DFN)
. ; drug class unknown, set flag
. I P("SC"),'P("UNK"),MED("CLASS")="" S P("UNK")=1
. ; exclude supplies
. I 'P("SU"),MED("CLASS")["XA",MED("DEA")["S" Q
. M OCL(INDEX)=MED
. ; use xstr to eliminiate inactive duplicates
. N XSTR S XSTR=$TR($$ADDMED(.TARGET,.OCL,.P,"","",INDEX,1),"""","") I $L(XSTR)>99 S XSTR=$E(XSTR,1,30)_"_"_$L(XSTR)
. D ; check if inactive duplicate
. . Q:P("AS")[MED("STATUS")!(P("PS")[MED("STATUS"))
. . ; set subscripts=MEDS(type_status,class,xstr)
. . N SUBS S SUBS="MEDS("_MED("SORT")_","""_$S(P("SC")&($G(MED("CLASS"))'=""):MED("CLASS"),1:" ")_""","""_XSTR_""")"
. . I $O(@SUBS@(0)) D Q:$O(@SUBS@(0))
. . . N IEN S IEN=$O(@SUBS@(0)) Q:'IEN
. . . ; compare issue/start date, keep newer
. . . I $P(OCL(INDEX,0),U,15)'<@SUBS@(IEN) K @SUBS@(IEN)
. ; MEDS(type_status,class,xstr,index)=issue/start date
. S MEDS(MED("SORT"),$S(P("SC")&($G(MED("CLASS"))'=""):MED("CLASS"),1:" "),XSTR,INDEX)=$P(OCL(INDEX,0),U,15)
EX D TITLE(.TARGET,.P,$D(MEDS))
I '$D(MEDS) D ADD(.TARGET,"No Medications Found"),ADD(.TARGET," ")
I $D(MEDS) D OUTPUT(.TARGET,.MEDS,.OCL,.P)
K TIUDATE ; Med Reconciliation
Q "~@"_$NA(@TARGET)
CLASS(MED,DFN) ;
N DATA S DATA=$$MEDCLASS(MED("NAME")) I +DATA S MED("CLASS")=$P(DATA,U,2),MED("DEA")=$P(DATA,U,3) Q
S (MED("CLASS"),MED("DEA"),MED("IEN"),MED("ORIDX"))=""
; prescription file #52
I MED("FILE")="R;O" D
. D RX^PSO52API(DFN,"TIUMEDOBJ",MED("ORDER #"),"","0,O")
. S MED("IEN")=+$G(^TMP($J,"TIUMEDOBJ",DFN,MED("ORDER #"),6))
. S MED("ORIDX")=+$G(^TMP($J,"TIUMEDOBJ",DFN,MED("ORDER #"),"OI"))
; pending outpatient order file #52.41
I MED("FILE")="P;O" D
. D PEN^PSO5241(DFN,"TIUMEDOBJ",MED("ORDER #"))
. S MED("IEN")=+$G(^TMP($J,"TIUMEDOBJ",DFN,MED("ORDER #"),11))
. S MED("ORIDX")=+$G(^TMP($J,"TIUMEDOBJ",DFN,MED("ORDER #"),8))
; pending inpatient order file #53.1
I MED("FILE")="P;I" D
. S MED("ORIDX")=$P($G(^PS(53.1,MED("ORDER #"),.2)),U)
. Q:$P($G(^PS(53.1,MED("ORDER #"),1,0)),U,4)'=1
. N IEN S IEN=$O(^PS(53.1,MED("ORDER #"),1,0)) Q:'IEN
. S MED("IEN")=$P($G(^PS(53.1,MED("ORDER #"),1,IEN,0)),U)
; unit dose order file #55, subfile #55.06
I MED("FILE")="U;I" D
. D PSS431^PSS55(DFN,MED("ORDER #"),"","","TIUMEDOBJ")
. Q:+$G(^TMP($J,"TIUMEDOBJ",MED("ORDER #"),"DDRUG",0))'=1
. N IEN S IEN=$O(^TMP($J,"TIUMEDOBJ",MED("ORDER #"),"DDRUG",0)) Q:'IEN
. S MED("IEN")=$G(^TMP($J,"TIUMEDOBJ",MED("ORDER #"),"DDRUG",IEN,.01))
. S MED("IEN")=+MED("IEN"),MED("ORIDX")=+$G(^TMP($J,"TIUMEDOBJ",MED("ORDER #"),108))
; IV order file #55, subfile #55.01
I MED("FILE")="V;I" D
. N X3 D PSS436^PSS55(DFN,MED("ORDER #"),"TIUMEDOBJ")
. S MED("ORIDX")=+$G(^TMP($J,"TIUMEDOBJ",MED("ORDER #"),130))
. Q:^TMP($J,"TIUMEDOBJ",MED("ORDER #"),"ADD",0)'=1
. N IEN S IEN=$O(^TMP($J,"TIUMEDOBJ",MED("ORDER #"),"ADD",0)) Q:'IEN
. S IEN=+$G(^TMP($J,"TIUMEDOBJ",MED("ORDER #"),"ADD",IEN,.01)) Q:'IEN
. K ^TMP($J,"DRGIEN_TIUMEDOBJ") D ZERO^PSS52P6(IEN,"","","DRGIEN_TIUMEDOBJ")
. S MED("IEN")=+$G(^TMP($J,"DRGIEN_TIUMEDOBJ",IEN,1))
. K ^TMP($J,"DRGIEN_TIUMEDOBJ")
S DATA=$$MEDCLASS(,MED("IEN")) I +DATA S MED("CLASS")=$P(DATA,U,2),MED("DEA")=$P(DATA,U,3) Q
; order # or no orderable item #
Q:MED("IEN")!('MED("ORIDX"))
; orderable item(s), file #50.7
K ^TMP($J,"DRGIEN_TIUMEDOBJ") D DRGIEN^PSS50P7(MED("ORIDX"),"","DRGIEN_TIUMEDOBJ")
N IEN S IEN=0 F S IEN=$O(^TMP($J,"DRGIEN_TIUMEDOBJ",IEN)) Q:'IEN D Q:+DATA
. S DATA=$$MEDCLASS(,IEN) I +DATA S MED("CLASS")=$P(DATA,U,2),MED("DEA")=$P(DATA,U,3)
K ^TMP($J,"DRGIEN_TIUMEDOBJ")
Q
MEDCLASS(NAME,IEN) ;
N CLASS,DEA K ^TMP($J,"TIUMEDOBJ") S IEN=$G(IEN),NAME=$G(NAME)
; drug file #50
D ZERO^PSS50(IEN,NAME,"","","","TIUMEDOBJ")
S IEN=+$O(^TMP($J,"TIUMEDOBJ",0)),CLASS=$G(^TMP($J,"TIUMEDOBJ",IEN,2)),DEA=$G(^TMP($J,"TIUMEDOBJ",IEN,3))
K ^TMP($J,"TIUMEDOBJ")
Q IEN_U_CLASS_U_DEA
OUTPUT(TARGET,MEDS,OCL,P) ;
N CLASS,COL,CNT,SORT,UL,XSTR S (SORT,UL)="",$P(UL,"=",80)="="
; set column start/widths for standard and detailed output
I 'P("D") D
. S COL(1,"W")=60,COL(0)=1,COL(1)=6,COL(2)=68
. I P("O"),'P("M"),'P("SC") S CNT="",COL(1)=1,COL(1,"W")=58 ; onelist
I P("D") D
. S COL(1,"W")=44,COL(2,"W")=12
. S COL(0)=1,COL(1)=6,COL(2)=53,COL(3)=66
; start formatting output
F S SORT=$O(MEDS(SORT)) Q:'SORT D
. N LN,STATUS S STATUS=$E(SORT,2),STATUS=$S(STATUS=1:"Active ",STATUS=2:"Pending ",STATUS=3:"Inactive ")
. N TYPE S TYPE=$E(SORT),TYPE=$S(TYPE=1:"Clinic",TYPE=4:"Non-VA",1:$S(P("INP"):$S(TYPE=2:"Inpatient",TYPE=3:"Outpatient"),1:$S(TYPE=3:"Inpatient",TYPE=2:"Outpatient")))
. S CNT("CLASS")=0
. ; set header by class
. I 'P("D") D
. . Q:P("O")&('P("M"))&('P("SC")) ; onelist
. . S LN=$S('P("O"):STATUS,1:"")_TYPE_" Medications"_$S(P("M")=4:" and Infusions",1:"")_$S(P("SC"):" (By Drug Class)",1:"")
. . S LN=$$SETSTR("Status",$$SETSTR(LN,"",COL(1),$L(LN)),COL(2),6)
. I P("D") D
. . I TYPE="Outpatient" D ADD(.TARGET,$$SETSTR("Issue Date","",COL(3),10)),ADD(.TARGET,$$SETSTR("Status",$$SETSTR("Last Fill","",COL(3),9),COL(2),6))
. . E D ADD(.TARGET,$$SETSTR("Start Date","",COL(3),10))
. . S LN=$S('P("O"):STATUS,1:"")_TYPE_" Medications"_$S(P("M")=4:" and Infusions",1:"")_$S(P("SC"):" (By Class)",1:""),LN=$$SETSTR(LN,"",COL(1),$L(LN))
. . I TYPE="Outpatient" S LN=$$SETSTR("Expiration",$$SETSTR("Refills",LN,COL(2),7),COL(3),10)
. . E S LN=$$SETSTR("Stop Date",$$SETSTR("Status",LN,COL(2),6),COL(3),9)
. ; add class header/underline
. D:$G(LN)'="" ADD(.TARGET,LN),ADD(.TARGET,$$SETSTR(UL,"",2,78))
. ; begin meds by class
. S CLASS="" F S CLASS=$O(MEDS(SORT,CLASS)) Q:CLASS="" D
. . ; sorting by class
. . I P("SC") D
. . . I CLASS=" "!(P("SC")=2) N X S X=" Drug Class: "_$S(CLASS=" ":"Unknown ",P("SC")=2:CLASS_" ") D ADD(.TARGET,$$SETSTR(X,$$SETSTR(UL,"",6,$S(P("D"):46,1:61)),16,$L(X)))
. . ; begin meds by xstr
. . S XSTR="" F S XSTR=$O(MEDS(SORT,CLASS,XSTR)) Q:XSTR="" D
. . . ; begin meds by index
. . . N INDEX S INDEX=0 F S INDEX=$O(MEDS(SORT,CLASS,XSTR,INDEX)) Q:'INDEX D
. . . . S CNT("CLASS")=CNT("CLASS")+1,CNT(SORT,CLASS)=$G(CNT(SORT,CLASS))+1,CNT("TOTAL")=$G(CNT("TOTAL"))+1
. . . . ; add the med to output
. . . . D ADDMED(.TARGET,.OCL,.P,.COL,$S(P("SC"):CNT("CLASS"),1:CNT(SORT,CLASS)),INDEX,0)
. . I P("SC") D:$O(MEDS(SORT,CLASS))'="" ADD(.TARGET," ")
. . I P("SC")=1,$O(MEDS(SORT,CLASS))'="" D ADD(.TARGET,$$SETSTR(UL,"",4,$S(P("D"):43,1:61)))
. D:$O(MEDS(SORT))'="" ADD(.TARGET," ")
I CNT("TOTAL")'=CNT("CLASS") D ADD(.TARGET," "),ADD(.TARGET,CNT("TOTAL")_" Total Medications")
D ADD(.TARGET," ")
Q
ADDMED(TARGET,OCL,P,COL,CNT,INDEX,XSTR) ;
N DATA,IND,REP,TEMP,TIUFT,TYPE,X,Y S DATA=$$TRIM^XLFSTR($P(OCL(INDEX,0),U,2))
S REP("^^")=" ",TYPE=$S(OCL(INDEX,"TYPE")="O":"OP",+$O(OCL(INDEX,"A",0))!(+$O(OCL(INDEX,"B",0))):"IV",1:"UD")
; set desired data nodes for output
I TYPE="IV" D
. I 'XSTR,P("D") D
. . S DATA(1)=DATA,DATA(2)=$$TRIM^XLFSTR($TR($$REPLACE^XLFSTR($$NODE(.OCL,INDEX,"A")_U_$S($O(OCL(INDEX,"B",0)):"in",1:"")_U_$$NODE(.OCL,INDEX,"B")_U_$P(OCL(INDEX,0),U,3),.REP),U," "))
. . S DATA(3)=$TR($$REPLACE^XLFSTR($$NODE(.OCL,INDEX,"SIO;MDR;SCH"),.REP),U," ")
. S DATA=$TR($$REPLACE^XLFSTR(DATA_U_$$NODE(.OCL,INDEX,"A")_U_$S($O(OCL(INDEX,"B",0)):"in",1:"")_U_$$NODE(.OCL,INDEX,"B")_U_$P(OCL(INDEX,0),U,3)_U_$$NODE(.OCL,INDEX,"SIO;MDR;SCH"),.REP),U," ")
I TYPE="UD" D
. I 'XSTR,P("D") D
. . S DATA(1)=DATA,DATA(2)=$S($P(OCL(INDEX,0),U,6)'="":"Give: "_$P(OCL(INDEX,0),U,6),$P(OCL(INDEX,0),U,7)'="":"Give: "_$P(OCL(INDEX,0),U,7),1:$$NODE(.OCL,INDEX,"SIG"))
. . S DATA(2)=$TR($$REPLACE^XLFSTR($$TRIM^XLFSTR(DATA(2))_U_$$NODE(.OCL,INDEX,"MDR;SCH"),.REP),U," ")
. . S DATA(3)=$TR($$REPLACE^XLFSTR($$NODE(.OCL,INDEX,"SIO"),.REP),U," ")
. S DATA=DATA_U_$S($P(OCL(INDEX,0),U,6)'="":$P(OCL(INDEX,0),U,6),$P(OCL(INDEX,0),U,7)'="":$P(OCL(INDEX,0),U,7),1:$$NODE(.OCL,INDEX,"SIG"))
. S DATA=$TR($$REPLACE^XLFSTR(DATA_U_$$NODE(.OCL,INDEX,"MDR;SCH")_U_$$NODE(.OCL,INDEX,"SIO"),.REP),U," ")
I TYPE="OP" D
. I P("D") S:$P(OCL(INDEX,0),U,12)'="" DATA=DATA_" Qty: "_$P(OCL(INDEX,0),U,12) S:$P(OCL(INDEX,0),U,11)'="" DATA=DATA_" for "_$P(OCL(INDEX,0),U,11)_" days"
. N TEMP S TEMP=$$NODE(.OCL,INDEX,"SIG") S:TEMP'="" DATA=DATA_U_$S(P("D"):"Sig: ",1:"")_TEMP S:TEMP="" DATA=DATA_U_$$NODE(.OCL,INDEX,"SIO;MDR;SCH") S DATA=$TR($$REPLACE^XLFSTR(DATA,.REP),U," ")
; return xstr
S DATA=$$TRIM^XLFSTR(DATA) Q:XSTR DATA
; get indication, remove indication from data output
S IND=$G(OCL(INDEX,"IND",0)) I IND'="" S REP(IND)="",DATA=$$REPLACE^XLFSTR(DATA,.REP)
; wrap data for detailed output, put in TIUFT
I 'XSTR,P("D") S (X,Y)=0 F S X=$O(DATA(X)) Q:'X D WRAP^TIUFLD(DATA(X),COL(1,"W")) D I '$O(DATA(X)) K TIUFT M TIUFT=TEMP
. S Y=$O(TEMP(""),-1) N X S X=0 F S X=$O(TIUFT(X)) Q:'X S TEMP(X+Y)=TIUFT(X) K TIUFT(X)
; wrap data for standard output
N SORT S SORT=$E(OCL(INDEX,"SORT")) D:'$D(TIUFT) WRAP^TIUFLD(DATA,COL(1,"W"))
; detailed ouput requires minimum of 2 or 3 (outpatient) lines, set null if needed
I P("D") F TIUFT=1:1:$S(SORT=P("SORT","O"):3,1:2) I $G(TIUFT(TIUFT))="" S TIUFT(TIUFT)=""
; begin wrap data output
S (IND(0),X)=0 F S X=$O(TIUFT(X)) Q:'X D
. S:X>1 CNT=""
. ; for 2nd or 3rd line, detailed output, null, add indication & set flag
. I X=2!(X=3),'IND(0),IND'="",P("D"),TIUFT(X)="" S IND(0)=1,TEMP="Indication: "_IND D
. . K TIUFT D WRAP^TIUFLD(TEMP,COL(1,"W")) S Y=0 F S Y=$O(TIUFT(Y)) Q:'Y S TEMP(X+(Y-1))=TIUFT(Y) K TIUFT(Y)
. . S Y=0 F S Y=$O(TEMP(Y)) Q:'Y S TIUFT(Y)=$$SETSTR(TEMP(Y),"",$S(Y=X:1,1:3),$L(TEMP(Y)))
. ; add number/count for med if needed
. S DATA=$$SETSTR($S(CNT:CNT_")",1:""),"",COL(0),$L($S(CNT:CNT_")",1:"")))
. ; add med to data
. S DATA=$$SETSTR(TIUFT(X),DATA,$S(X=1!(IND(0)):COL(1),1:COL(1)+2),$L(TIUFT(X)))
. ; add status, wrap if needed
. I X=1 N Y S Y=$P(OCL(INDEX,0),U,9) S:$L(Y)<13 DATA=$$SETSTR(Y,DATA,COL(2),$L(Y)) D:$L(Y)>12
. . S DATA=$$SETSTR($P(Y," "),DATA,COL(2),$L($P(Y," ")))
. . S TIUFT(2)=$$SETSTR($P(Y," ",2),$S($G(TIUFT(2))="":"",1:TIUFT(2)),COL(2)-7,$L($P(Y," ",2)))
. ; detailed output
. I P("D") D
. . I X=1,$P(OCL(INDEX,0),U,15) N X S X=$S(SORT=P("SORT","O"):"Issue: ",1:"Start: ")_$$FMTE^XLFDT($P($P(OCL(INDEX,0),U,15),"."),"2Z"),DATA=$$SETSTR(X,DATA,COL(3),$L(X))
. . I X=2,SORT=P("SORT","O") N X S X="Refills: "_+$P(OCL(INDEX,0),U,5) S DATA=$$SETSTR(X,DATA,COL(2),$L(X)) D
. . . I $P(OCL(INDEX,0),U,10) S X="Last : "_$$FMTE^XLFDT($P($P(OCL(INDEX,0),U,10),"."),"2Z") S DATA=$$SETSTR(X,DATA,COL(3),$L(X))
. . ; standard output
. . I X=2,SORT'=P("SORT","O"),$P(OCL(INDEX,0),U,4) N X S X="Stop : "_$$FMTE^XLFDT($P($P(OCL(INDEX,0),U,4),"."),"2Z"),DATA=$$SETSTR(X,DATA,COL(3),$L(X))
. . I X=3,SORT=P("SORT","O"),$P(OCL(INDEX,0),U,4) N X S X="Expr : "_$$FMTE^XLFDT($P($P(OCL(INDEX,0),U,4),"."),"2Z"),DATA=$$SETSTR(X,DATA,COL(3),$L(X))
. ; add data to output
. D:DATA'="" ADD(.TARGET,$$TRIM^XLFSTR(DATA,"R"))
; add indication if needed
I 'IND(0),IND'="" S TEMP="Indication: "_IND K TIUFT D WRAP^TIUFLD(TEMP,COL(1,"W")) D
. S X=0 F S X=$O(TIUFT(X)) Q:'X D ADD(.TARGET,$$SETSTR(TIUFT(X),"",$S(X=1:COL(1),1:COL(1)+2),$L(TIUFT(X))))
Q
ADD(TARGET,DATA) ;
S @TARGET@(($O(@TARGET@(""),-1)+1),0)=DATA
Q
NODE(OCL,IDX,NODES) ;
N DATA,NODE,X,Y S DATA="" F X=1:1:$L(NODES,";") S NODE=$P(NODES,";",X),Y=0 F S Y=$O(OCL(IDX,NODE,Y)) Q:'Y S DATA=DATA_$S(DATA="":"",1:U)_$$TRIM^XLFSTR(OCL(IDX,NODE,Y,0))
Q DATA
SETSTR(S,V,X,L) ;
Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
TITLE(TARGET,P,SHOW) ;
N DATA S DATA=$S('P("A"):"Active and Recently Expired ",P("A")=1:"Active ",1:"Recently Expired ")
S DATA=DATA_$S('P("M"):$S(P("INP"):"Inpatient ",1:"Outpatient "),P("M")=1:"Inpatient, Outpatient and Clinic ",P("M")=2:"Inpatient ",P("M")=3:"Outpatient ",1:"")
S DATA=DATA_$S(P("M")=4:"Clinic ",P("M")=5:"Inpatient & Clinic ",P("M")=6:"Outpatient & Clinic ",1:"")_"Medications"_" ("_$S(P("SU"):"in",1:"ex")_"cluding Supplies):"
N TIUFT D WRAP^TIUFLD(DATA,80) S TIUFT=0 F S TIUFT=$O(TIUFT(TIUFT)) Q:'TIUFT D ADD(.TARGET,TIUFT(TIUFT)) D:'$O(TIUFT(TIUFT)) ADD(.TARGET," ")
I SHOW,P("SC") D ADD(.TARGET," WARNING Sorting by drug class may be inaccurate.") D
. D ADD(.TARGET,"Multi-classed medications will only be displayed under a single drug class.") I 'P("UNK") D ADD(.TARGET," ")
I P("UNK") D ADD(.TARGET,"The system may not be able to determine the drug class of some medications."),ADD(.TARGET," ")
Q
UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUMOBJ 18126 printed Sep 23, 2025@20:18:54 Page 2
TIUMOBJ ;XAN/AJB - MEDICATION OBJECT ;Aug 02, 2024@13:51:30
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**365**;Jun 20, 1997;Build 1
+2 ;
+3 ; Reference to ^DIM in ICR #10016
+4 ; Reference to ^DPT( in ICR #10035
+5 ; Reference to PEN^PSO5241 in ICR #4821
+6 ; Reference to RX^PSO52API in ICR #4820
+7 ; Reference to OCL^PSOORRL in ICR #2400
+8 ; Reference to DRGIEN^PSS50P7 in ICR #4662
+9 ; Reference to *^PSS55 in ICR #4826
+10 ; Reference to *^XLFDT in ICR #10103
+11 ; Reference to *^XLFSTR in ICR #10104
+12 ;
+13 ; Required Parameter
+14 ; DFN Patient IEN
+15 ;
+16 ; Optional Parameters
+17 ; TARGET Return Location of data [default "OUTPUT"]
+18 ; Global TARGET must be ^TMP with at least one subscript
+19 ; A (active) 0 Active and recently expired meds [default]
+20 ; 1 Active meds only
+21 ; 2 Recently expired meds only
+22 ; D (detailed) 0 Standard med info [default]
+23 ; 1 Detailed med info
+24 ; M (meds) 0 Inpatient or Outpatient meds only, based on patient status [default]
+25 ; 1 Inpatient, outpatient & clinic meds
+26 ; 2/"I" Inpatient meds only
+27 ; 3/"O" Outpatient meds only
+28 ; 4/"C" Clinic meds only
+29 ; 5/"CI" Clinic and inpatient meds only
+30 ; 6/"CI" Clinic and outpatient meds only
+31 ; O (onelist) 0 Separates based on status [default]
+32 ; 1 Combines meds into one list per type
+33 ; SC (sort by class) 0 Sort meds alphabetically [default]
+34 ; 1 Sort by class, alphabetically
+35 ; 2 Sort by class with class in header
+36 ; SU (supplies) 0 Exclude supplies
+37 ; 1 Include supplies [default]
+38 ; Global Variable
+39 ; TIUDATE # of days to search from today [Med Reconciliation TIU*1.0*238 & PSO*7.0*294]
+40 ;
+41 QUIT
LIST(DFN,TARGET,A,D,M,O,SC,SU) ;
+1 ; validate target, default to OUTPUT if needed
+2 NEW P,X
SET DFN=+$GET(DFN)
SET TARGET=$GET(TARGET,"OUTPUT")
SET TARGET=$SELECT(TARGET[""""""!(TARGET[U&(TARGET'["^TMP(")):"OUTPUT",1:TARGET)
+3 ; DIM checks syntax, ensures valid TARGET
+4 SET X="S TEST="_TARGET
DO ^DIM
SET TARGET=$SELECT('$DATA(X):"OUTPUT",1:TARGET)
+5 ; validate patient
+6 IF 'DFN!(DFN&('$DATA(^DPT(DFN))))
DO ADD(.TARGET,$SELECT('DFN:"No Patient ID",1:"Patient DFN invalid"))
QUIT "~@"_$NAME(@TARGET)
+7 KILL @TARGET,^TMP("PS",$JOB)
+8 ; verify/set routine parameters in P(parameter)
+9 FOR X="A","D","M","O","SC","SU"
Begin DoDot:1
+10 if X="A"
SET A=$SELECT(+$GET(A)'<0&(+$GET(A)<3):+$GET(A),1:0)
+11 if X="D"
SET D=$SELECT(+$GET(D)'<0&(+$GET(D)<2):+$GET(D),1:0)
+12 if X="M"
SET M=$$UP($GET(M))
SET M=$SELECT(M="I":2,M="O":3,M="C":4,M="CI"!(M="IC"):5,M="CO"!(M="OC"):6,+$GET(M)'<0&(+$GET(M)<7):+$GET(M),1:0)
+13 if X="O"
SET O=$SELECT(+$GET(O)'<0&(+$GET(O)<2):+$GET(O),1:0)
+14 if X="SC"
SET SC=$SELECT(+$GET(SC)'<0&(+$GET(SC)<3):+$GET(SC),1:0)
+15 if X="SU"
SET SU=$SELECT($GET(SU)="":1,+$GET(SU)=0:0,1:1)
+16 SET P(X)=@(X)
KILL @(X)
if X="SU"
KILL X
End DoDot:1
+17 ; additional parameters/data
+18 SET P("AS")="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^ACTIVE/PARKED^"
+19 SET P("PS")="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
+20 ; sort order of inpatient/outpatient determined by patient status
+21 SET P("INP")=($GET(^DPT(DFN,.1))'="")
SET P("SORT","I")=$SELECT(P("INP"):2,1:3)
SET P("SORT","O")=$SELECT(P("INP"):3,1:2)
+22 ; flag for any drug with unknown class, evaluated in TITLE output
+23 SET P("UNK")=0
+24 ; variables left after external calls
+25 NEW %H,BDT1,D0,DILOCKTM,DIQ2,DISYS,DRG,GP,IEN,LSTDS,LSTFD,LSTRD,ND2P5,PSSTMP2,RNWDT,SG
+26 ; get med data
+27 DO OCL^PSOORRL(DFN,$SELECT('$GET(TIUDATE):"",1:$$FMADD^XLFDT(DT,-$GET(TIUDATE))))
if '$DATA(^TMP("PS",$JOB))
GOTO EX
+28 NEW INDEX,MEDS,OCL
MERGE OCL=^TMP("PS",$JOB)
KILL ^TMP("PS",$JOB)
+29 SET INDEX=0
FOR
SET INDEX=$ORDER(OCL(INDEX))
if 'INDEX
QUIT
Begin DoDot:1
+30 NEW MED
SET MED("NAME")=$TRANSLATE($PIECE(OCL(INDEX,0),U,2),"""","")
if MED("NAME")=""
QUIT
+31 ; TIU*238 & PSO*7.0*294 (Med Reconciliation)
+32 if $PIECE(OCL(INDEX,0),U,9)["DISCONTINUED"&($GET(TIUDATE))
QUIT
+33 if $PIECE(OCL(INDEX,0),U,9)="ACTIVE/SUSP"
SET $PIECE(OCL(INDEX,0),U,9)="ACTIVE (S)"
+34 SET MED("STATUS")=$PIECE(OCL(INDEX,0),U,9)
+35 SET MED("ORDER #")=+OCL(INDEX,0)
+36 SET MED("CLINIC")=($GET(OCL(INDEX,"CLINIC",0))>0)
+37 SET MED("FILE")=$TRANSLATE($PIECE(OCL(INDEX,0),U),MED("ORDER #"),"")
+38 SET MED("TYPE")=$PIECE(MED("FILE"),";",2)
if MED("TYPE")=""
QUIT
+39 ; sort order: clinic=1, in/outpatient (based on patient status)=2/3, 4=Non-VA Meds
+40 SET MED("SORT")=$SELECT(MED("CLINIC"):1,MED("FILE")="N;O":4,MED("TYPE")="I":P("SORT","I"),MED("TYPE")="O":P("SORT","O"))
+41 ; sort=type_status
+42 SET MED("SORT")=MED("SORT")_$SELECT(P("O")!(P("AS")[MED("STATUS")):1,P("PS")[MED("STATUS"):2,1:3)
+43 ; add prefix if needed
+44 if MED("FILE")="N;O"
SET $PIECE(OCL(INDEX,0),U,2)="Non-VA "_$PIECE(OCL(INDEX,0),U,2)
+45 ; all active/pending inactive
+46 if $SELECT('P("A")
QUIT
+47 ; in/outpatient all inpatient outpatient
+48 if $SELECT(P("M")=0
QUIT
+49 ; clinic meds & inpatient & outpatient
+50 if $SELECT(P("M")'<4
QUIT
+51 ; get med class, needed for sorting by class or to exclude supplies
+52 IF P("SC")!('P("SU"))
DO CLASS(.MED,DFN)
+53 ; drug class unknown, set flag
+54 IF P("SC")
IF 'P("UNK")
IF MED("CLASS")=""
SET P("UNK")=1
+55 ; exclude supplies
+56 IF 'P("SU")
IF MED("CLASS")["XA"
IF MED("DEA")["S"
QUIT
+57 MERGE OCL(INDEX)=MED
+58 ; use xstr to eliminiate inactive duplicates
+59 NEW XSTR
SET XSTR=$TRANSLATE($$ADDMED(.TARGET,.OCL,.P,"","",INDEX,1),"""","")
IF $LENGTH(XSTR)>99
SET XSTR=$EXTRACT(XSTR,1,30)_"_"_$LENGTH(XSTR)
+60 ; check if inactive duplicate
Begin DoDot:2
+61 if P("AS")[MED("STATUS")!(P("PS")[MED("STATUS"))
QUIT
+62 ; set subscripts=MEDS(type_status,class,xstr)
+63 NEW SUBS
SET SUBS="MEDS("_MED("SORT")_","""_$SELECT(P("SC")&($GET(MED("CLASS"))'=""):MED("CLASS"),1:" ")_""","""_XSTR_""")"
+64 IF $ORDER(@SUBS@(0))
Begin DoDot:3
+65 NEW IEN
SET IEN=$ORDER(@SUBS@(0))
if 'IEN
QUIT
+66 ; compare issue/start date, keep newer
+67 IF $PIECE(OCL(INDEX,0),U,15)'<@SUBS@(IEN)
KILL @SUBS@(IEN)
End DoDot:3
if $ORDER(@SUBS@(0))
QUIT
End DoDot:2
+68 ; MEDS(type_status,class,xstr,index)=issue/start date
+69 SET MEDS(MED("SORT"),$SELECT(P("SC")&($GET(MED("CLASS"))'=""):MED("CLASS"),1:" "),XSTR,INDEX)=$PIECE(OCL(INDEX,0),U,15)
End DoDot:1
EX DO TITLE(.TARGET,.P,$DATA(MEDS))
+1 IF '$DATA(MEDS)
DO ADD(.TARGET,"No Medications Found")
DO ADD(.TARGET," ")
+2 IF $DATA(MEDS)
DO OUTPUT(.TARGET,.MEDS,.OCL,.P)
+3 ; Med Reconciliation
KILL TIUDATE
+4 QUIT "~@"_$NAME(@TARGET)
CLASS(MED,DFN) ;
+1 NEW DATA
SET DATA=$$MEDCLASS(MED("NAME"))
IF +DATA
SET MED("CLASS")=$PIECE(DATA,U,2)
SET MED("DEA")=$PIECE(DATA,U,3)
QUIT
+2 SET (MED("CLASS"),MED("DEA"),MED("IEN"),MED("ORIDX"))=""
+3 ; prescription file #52
+4 IF MED("FILE")="R;O"
Begin DoDot:1
+5 DO RX^PSO52API(DFN,"TIUMEDOBJ",MED("ORDER #"),"","0,O")
+6 SET MED("IEN")=+$GET(^TMP($JOB,"TIUMEDOBJ",DFN,MED("ORDER #"),6))
+7 SET MED("ORIDX")=+$GET(^TMP($JOB,"TIUMEDOBJ",DFN,MED("ORDER #"),"OI"))
End DoDot:1
+8 ; pending outpatient order file #52.41
+9 IF MED("FILE")="P;O"
Begin DoDot:1
+10 DO PEN^PSO5241(DFN,"TIUMEDOBJ",MED("ORDER #"))
+11 SET MED("IEN")=+$GET(^TMP($JOB,"TIUMEDOBJ",DFN,MED("ORDER #"),11))
+12 SET MED("ORIDX")=+$GET(^TMP($JOB,"TIUMEDOBJ",DFN,MED("ORDER #"),8))
End DoDot:1
+13 ; pending inpatient order file #53.1
+14 IF MED("FILE")="P;I"
Begin DoDot:1
+15 SET MED("ORIDX")=$PIECE($GET(^PS(53.1,MED("ORDER #"),.2)),U)
+16 if $PIECE($GET(^PS(53.1,MED("ORDER #"),1,0)),U,4)'=1
QUIT
+17 NEW IEN
SET IEN=$ORDER(^PS(53.1,MED("ORDER #"),1,0))
if 'IEN
QUIT
+18 SET MED("IEN")=$PIECE($GET(^PS(53.1,MED("ORDER #"),1,IEN,0)),U)
End DoDot:1
+19 ; unit dose order file #55, subfile #55.06
+20 IF MED("FILE")="U;I"
Begin DoDot:1
+21 DO PSS431^PSS55(DFN,MED("ORDER #"),"","","TIUMEDOBJ")
+22 if +$GET(^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),"DDRUG",0))'=1
QUIT
+23 NEW IEN
SET IEN=$ORDER(^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),"DDRUG",0))
if 'IEN
QUIT
+24 SET MED("IEN")=$GET(^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),"DDRUG",IEN,.01))
+25 SET MED("IEN")=+MED("IEN")
SET MED("ORIDX")=+$GET(^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),108))
End DoDot:1
+26 ; IV order file #55, subfile #55.01
+27 IF MED("FILE")="V;I"
Begin DoDot:1
+28 NEW X3
DO PSS436^PSS55(DFN,MED("ORDER #"),"TIUMEDOBJ")
+29 SET MED("ORIDX")=+$GET(^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),130))
+30 if ^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),"ADD",0)'=1
QUIT
+31 NEW IEN
SET IEN=$ORDER(^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),"ADD",0))
if 'IEN
QUIT
+32 SET IEN=+$GET(^TMP($JOB,"TIUMEDOBJ",MED("ORDER #"),"ADD",IEN,.01))
if 'IEN
QUIT
+33 KILL ^TMP($JOB,"DRGIEN_TIUMEDOBJ")
DO ZERO^PSS52P6(IEN,"","","DRGIEN_TIUMEDOBJ")
+34 SET MED("IEN")=+$GET(^TMP($JOB,"DRGIEN_TIUMEDOBJ",IEN,1))
+35 KILL ^TMP($JOB,"DRGIEN_TIUMEDOBJ")
End DoDot:1
+36 SET DATA=$$MEDCLASS(,MED("IEN"))
IF +DATA
SET MED("CLASS")=$PIECE(DATA,U,2)
SET MED("DEA")=$PIECE(DATA,U,3)
QUIT
+37 ; order # or no orderable item #
+38 if MED("IEN")!('MED("ORIDX"))
QUIT
+39 ; orderable item(s), file #50.7
+40 KILL ^TMP($JOB,"DRGIEN_TIUMEDOBJ")
DO DRGIEN^PSS50P7(MED("ORIDX"),"","DRGIEN_TIUMEDOBJ")
+41 NEW IEN
SET IEN=0
FOR
SET IEN=$ORDER(^TMP($JOB,"DRGIEN_TIUMEDOBJ",IEN))
if 'IEN
QUIT
Begin DoDot:1
+42 SET DATA=$$MEDCLASS(,IEN)
IF +DATA
SET MED("CLASS")=$PIECE(DATA,U,2)
SET MED("DEA")=$PIECE(DATA,U,3)
End DoDot:1
if +DATA
QUIT
+43 KILL ^TMP($JOB,"DRGIEN_TIUMEDOBJ")
+44 QUIT
MEDCLASS(NAME,IEN) ;
+1 NEW CLASS,DEA
KILL ^TMP($JOB,"TIUMEDOBJ")
SET IEN=$GET(IEN)
SET NAME=$GET(NAME)
+2 ; drug file #50
+3 DO ZERO^PSS50(IEN,NAME,"","","","TIUMEDOBJ")
+4 SET IEN=+$ORDER(^TMP($JOB,"TIUMEDOBJ",0))
SET CLASS=$GET(^TMP($JOB,"TIUMEDOBJ",IEN,2))
SET DEA=$GET(^TMP($JOB,"TIUMEDOBJ",IEN,3))
+5 KILL ^TMP($JOB,"TIUMEDOBJ")
+6 QUIT IEN_U_CLASS_U_DEA
OUTPUT(TARGET,MEDS,OCL,P) ;
+1 NEW CLASS,COL,CNT,SORT,UL,XSTR
SET (SORT,UL)=""
SET $PIECE(UL,"=",80)="="
+2 ; set column start/widths for standard and detailed output
+3 IF 'P("D")
Begin DoDot:1
+4 SET COL(1,"W")=60
SET COL(0)=1
SET COL(1)=6
SET COL(2)=68
+5 ; onelist
IF P("O")
IF 'P("M")
IF 'P("SC")
SET CNT=""
SET COL(1)=1
SET COL(1,"W")=58
End DoDot:1
+6 IF P("D")
Begin DoDot:1
+7 SET COL(1,"W")=44
SET COL(2,"W")=12
+8 SET COL(0)=1
SET COL(1)=6
SET COL(2)=53
SET COL(3)=66
End DoDot:1
+9 ; start formatting output
+10 FOR
SET SORT=$ORDER(MEDS(SORT))
if 'SORT
QUIT
Begin DoDot:1
+11 NEW LN,STATUS
SET STATUS=$EXTRACT(SORT,2)
SET STATUS=$SELECT(STATUS=1:"Active ",STATUS=2:"Pending ",STATUS=3:"Inactive ")
+12 NEW TYPE
SET TYPE=$EXTRACT(SORT)
SET TYPE=$SELECT(TYPE=1:"Clinic",TYPE=4:"Non-VA",1:$SELECT(P("INP"):$SELECT(TYPE=2:"Inpatient",TYPE=3:"Outpatient"),1:$SELECT(TYPE=3:"Inpatient",TYPE=2:"Outpatient")))
+13 SET CNT("CLASS")=0
+14 ; set header by class
+15 IF 'P("D")
Begin DoDot:2
+16 ; onelist
if P("O")&('P("M"))&('P("SC"))
QUIT
+17 SET LN=$SELECT('P("O"):STATUS,1:"")_TYPE_" Medications"_$SELECT(P("M")=4:" and Infusions",1:"")_$SELECT(P("SC"):" (By Drug Class)",1:"")
+18 SET LN=$$SETSTR("Status",$$SETSTR(LN,"",COL(1),$LENGTH(LN)),COL(2),6)
End DoDot:2
+19 IF P("D")
Begin DoDot:2
+20 IF TYPE="Outpatient"
DO ADD(.TARGET,$$SETSTR("Issue Date","",COL(3),10))
DO ADD(.TARGET,$$SETSTR("Status",$$SETSTR("Last Fill","",COL(3),9),COL(2),6))
+21 IF '$TEST
DO ADD(.TARGET,$$SETSTR("Start Date","",COL(3),10))
+22 SET LN=$SELECT('P("O"):STATUS,1:"")_TYPE_" Medications"_$SELECT(P("M")=4:" and Infusions",1:"")_$SELECT(P("SC"):" (By Class)",1:"")
SET LN=$$SETSTR(LN,"",COL(1),$LENGTH(LN))
+23 IF TYPE="Outpatient"
SET LN=$$SETSTR("Expiration",$$SETSTR("Refills",LN,COL(2),7),COL(3),10)
+24 IF '$TEST
SET LN=$$SETSTR("Stop Date",$$SETSTR("Status",LN,COL(2),6),COL(3),9)
End DoDot:2
+25 ; add class header/underline
+26 if $GET(LN)'=""
DO ADD(.TARGET,LN)
DO ADD(.TARGET,$$SETSTR(UL,"",2,78))
+27 ; begin meds by class
+28 SET CLASS=""
FOR
SET CLASS=$ORDER(MEDS(SORT,CLASS))
if CLASS=""
QUIT
Begin DoDot:2
+29 ; sorting by class
+30 IF P("SC")
Begin DoDot:3
+31 IF CLASS=" "!(P("SC")=2)
NEW X
SET X=" Drug Class: "_$SELECT(CLASS=" ":"Unknown ",P("SC")=2:CLASS_" ")
DO ADD(.TARGET,$$SETSTR(X,$$SETSTR(UL,"",6,$SELECT(P("D"):46,1:61)),16,$LENGTH(X)))
End DoDot:3
+32 ; begin meds by xstr
+33 SET XSTR=""
FOR
SET XSTR=$ORDER(MEDS(SORT,CLASS,XSTR))
if XSTR=""
QUIT
Begin DoDot:3
+34 ; begin meds by index
+35 NEW INDEX
SET INDEX=0
FOR
SET INDEX=$ORDER(MEDS(SORT,CLASS,XSTR,INDEX))
if 'INDEX
QUIT
Begin DoDot:4
+36 SET CNT("CLASS")=CNT("CLASS")+1
SET CNT(SORT,CLASS)=$GET(CNT(SORT,CLASS))+1
SET CNT("TOTAL")=$GET(CNT("TOTAL"))+1
+37 ; add the med to output
+38 DO ADDMED(.TARGET,.OCL,.P,.COL,$SELECT(P("SC"):CNT("CLASS"),1:CNT(SORT,CLASS)),INDEX,0)
End DoDot:4
End DoDot:3
+39 IF P("SC")
if $ORDER(MEDS(SORT,CLASS))'=""
DO ADD(.TARGET," ")
+40 IF P("SC")=1
IF $ORDER(MEDS(SORT,CLASS))'=""
DO ADD(.TARGET,$$SETSTR(UL,"",4,$SELECT(P("D"):43,1:61)))
End DoDot:2
+41 if $ORDER(MEDS(SORT))'=""
DO ADD(.TARGET," ")
End DoDot:1
+42 IF CNT("TOTAL")'=CNT("CLASS")
DO ADD(.TARGET," ")
DO ADD(.TARGET,CNT("TOTAL")_" Total Medications")
+43 DO ADD(.TARGET," ")
+44 QUIT
ADDMED(TARGET,OCL,P,COL,CNT,INDEX,XSTR) ;
+1 NEW DATA,IND,REP,TEMP,TIUFT,TYPE,X,Y
SET DATA=$$TRIM^XLFSTR($PIECE(OCL(INDEX,0),U,2))
+2 SET REP("^^")=" "
SET TYPE=$SELECT(OCL(INDEX,"TYPE")="O":"OP",+$ORDER(OCL(INDEX,"A",0))!(+$ORDER(OCL(INDEX,"B",0))):"IV",1:"UD")
+3 ; set desired data nodes for output
+4 IF TYPE="IV"
Begin DoDot:1
+5 IF 'XSTR
IF P("D")
Begin DoDot:2
+6 SET DATA(1)=DATA
SET DATA(2)=$$TRIM^XLFSTR($TRANSLATE($$REPLACE^XLFSTR($$NODE(.OCL,INDEX,"A")_U_$SELECT($ORDER(OCL(INDEX,"B",0)):"in",1:"")_U_$$NODE(.OCL,INDEX,"B")_U_$PIECE(OCL(INDEX,0),U,3),.REP),U," "))
+7 SET DATA(3)=$TRANSLATE($$REPLACE^XLFSTR($$NODE(.OCL,INDEX,"SIO;MDR;SCH"),.REP),U," ")
End DoDot:2
+8 SET DATA=$TRANSLATE($$REPLACE^XLFSTR(DATA_U_$$NODE(.OCL,INDEX,"A")_U_$SELECT($ORDER(OCL(INDEX,"B",0)):"in",1:"")_U_$$NODE(.OCL,INDEX,"B")_U_$PIECE(OCL(INDEX,0),U,3)_U_$$NODE(.OCL,INDEX,"SIO;MDR;SCH"),.REP),U," ")
End DoDot:1
+9 IF TYPE="UD"
Begin DoDot:1
+10 IF 'XSTR
IF P("D")
Begin DoDot:2
+11 SET DATA(1)=DATA
SET DATA(2)=$SELECT($PIECE(OCL(INDEX,0),U,6)'="":"Give: "_$PIECE(OCL(INDEX,0),U,6),$PIECE(OCL(INDEX,0),U,7)'="":"Give: "_$PIECE(OCL(INDEX,0),U,7),1:$$NODE(.OCL,INDEX,"SIG"))
+12 SET DATA(2)=$TRANSLATE($$REPLACE^XLFSTR($$TRIM^XLFSTR(DATA(2))_U_$$NODE(.OCL,INDEX,"MDR;SCH"),.REP),U," ")
+13 SET DATA(3)=$TRANSLATE($$REPLACE^XLFSTR($$NODE(.OCL,INDEX,"SIO"),.REP),U," ")
End DoDot:2
+14 SET DATA=DATA_U_$SELECT($PIECE(OCL(INDEX,0),U,6)'="":$PIECE(OCL(INDEX,0),U,6),$PIECE(OCL(INDEX,0),U,7)'="":$PIECE(OCL(INDEX,0),U,7),1:$$NODE(.OCL,INDEX,"SIG"))
+15 SET DATA=$TRANSLATE($$REPLACE^XLFSTR(DATA_U_$$NODE(.OCL,INDEX,"MDR;SCH")_U_$$NODE(.OCL,INDEX,"SIO"),.REP),U," ")
End DoDot:1
+16 IF TYPE="OP"
Begin DoDot:1
+17 IF P("D")
if $PIECE(OCL(INDEX,0),U,12)'=""
SET DATA=DATA_" Qty: "_$PIECE(OCL(INDEX,0),U,12)
if $PIECE(OCL(INDEX,0),U,11)'=""
SET DATA=DATA_" for "_$PIECE(OCL(INDEX,0),U,11)_" days"
+18 NEW TEMP
SET TEMP=$$NODE(.OCL,INDEX,"SIG")
if TEMP'=""
SET DATA=DATA_U_$SELECT(P("D"):"Sig: ",1:"")_TEMP
if TEMP=""
SET DATA=DATA_U_$$NODE(.OCL,INDEX,"SIO;MDR;SCH")
SET DATA=$TRANSLATE($$REPLACE^XLFSTR(DATA,.REP),U," ")
End DoDot:1
+19 ; return xstr
+20 SET DATA=$$TRIM^XLFSTR(DATA)
if XSTR
QUIT DATA
+21 ; get indication, remove indication from data output
+22 SET IND=$GET(OCL(INDEX,"IND",0))
IF IND'=""
SET REP(IND)=""
SET DATA=$$REPLACE^XLFSTR(DATA,.REP)
+23 ; wrap data for detailed output, put in TIUFT
+24 IF 'XSTR
IF P("D")
SET (X,Y)=0
FOR
SET X=$ORDER(DATA(X))
if 'X
QUIT
DO WRAP^TIUFLD(DATA(X),COL(1,"W"))
Begin DoDot:1
+25 SET Y=$ORDER(TEMP(""),-1)
NEW X
SET X=0
FOR
SET X=$ORDER(TIUFT(X))
if 'X
QUIT
SET TEMP(X+Y)=TIUFT(X)
KILL TIUFT(X)
End DoDot:1
IF '$ORDER(DATA(X))
KILL TIUFT
MERGE TIUFT=TEMP
+26 ; wrap data for standard output
+27 NEW SORT
SET SORT=$EXTRACT(OCL(INDEX,"SORT"))
if '$DATA(TIUFT)
DO WRAP^TIUFLD(DATA,COL(1,"W"))
+28 ; detailed ouput requires minimum of 2 or 3 (outpatient) lines, set null if needed
+29 IF P("D")
FOR TIUFT=1:1:$SELECT(SORT=P("SORT","O"):3,1:2)
IF $GET(TIUFT(TIUFT))=""
SET TIUFT(TIUFT)=""
+30 ; begin wrap data output
+31 SET (IND(0),X)=0
FOR
SET X=$ORDER(TIUFT(X))
if 'X
QUIT
Begin DoDot:1
+32 if X>1
SET CNT=""
+33 ; for 2nd or 3rd line, detailed output, null, add indication & set flag
+34 IF X=2!(X=3)
IF 'IND(0)
IF IND'=""
IF P("D")
IF TIUFT(X)=""
SET IND(0)=1
SET TEMP="Indication: "_IND
Begin DoDot:2
+35 KILL TIUFT
DO WRAP^TIUFLD(TEMP,COL(1,"W"))
SET Y=0
FOR
SET Y=$ORDER(TIUFT(Y))
if 'Y
QUIT
SET TEMP(X+(Y-1))=TIUFT(Y)
KILL TIUFT(Y)
+36 SET Y=0
FOR
SET Y=$ORDER(TEMP(Y))
if 'Y
QUIT
SET TIUFT(Y)=$$SETSTR(TEMP(Y),"",$SELECT(Y=X:1,1:3),$LENGTH(TEMP(Y)))
End DoDot:2
+37 ; add number/count for med if needed
+38 SET DATA=$$SETSTR($SELECT(CNT:CNT_")",1:""),"",COL(0),$LENGTH($SELECT(CNT:CNT_")",1:"")))
+39 ; add med to data
+40 SET DATA=$$SETSTR(TIUFT(X),DATA,$SELECT(X=1!(IND(0)):COL(1),1:COL(1)+2),$LENGTH(TIUFT(X)))
+41 ; add status, wrap if needed
+42 IF X=1
NEW Y
SET Y=$PIECE(OCL(INDEX,0),U,9)
if $LENGTH(Y)<13
SET DATA=$$SETSTR(Y,DATA,COL(2),$LENGTH(Y))
if $LENGTH(Y)>12
Begin DoDot:2
+43 SET DATA=$$SETSTR($PIECE(Y," "),DATA,COL(2),$LENGTH($PIECE(Y," ")))
+44 SET TIUFT(2)=$$SETSTR($PIECE(Y," ",2),$SELECT($GET(TIUFT(2))="":"",1:TIUFT(2)),COL(2)-7,$LENGTH($PIECE(Y," ",2)))
End DoDot:2
+45 ; detailed output
+46 IF P("D")
Begin DoDot:2
+47 IF X=1
IF $PIECE(OCL(INDEX,0),U,15)
NEW X
SET X=$SELECT(SORT=P("SORT","O"):"Issue: ",1:"Start: ")_$$FMTE^XLFDT($PIECE($PIECE(OCL(INDEX,0),U,15),"."),"2Z")
SET DATA=$$SETSTR(X,DATA,COL(3),$LENGTH(X))
+48 IF X=2
IF SORT=P("SORT","O")
NEW X
SET X="Refills: "_+$PIECE(OCL(INDEX,0),U,5)
SET DATA=$$SETSTR(X,DATA,COL(2),$LENGTH(X))
Begin DoDot:3
+49 IF $PIECE(OCL(INDEX,0),U,10)
SET X="Last : "_$$FMTE^XLFDT($PIECE($PIECE(OCL(INDEX,0),U,10),"."),"2Z")
SET DATA=$$SETSTR(X,DATA,COL(3),$LENGTH(X))
End DoDot:3
+50 ; standard output
+51 IF X=2
IF SORT'=P("SORT","O")
IF $PIECE(OCL(INDEX,0),U,4)
NEW X
SET X="Stop : "_$$FMTE^XLFDT($PIECE($PIECE(OCL(INDEX,0),U,4),"."),"2Z")
SET DATA=$$SETSTR(X,DATA,COL(3),$LENGTH(X))
+52 IF X=3
IF SORT=P("SORT","O")
IF $PIECE(OCL(INDEX,0),U,4)
NEW X
SET X="Expr : "_$$FMTE^XLFDT($PIECE($PIECE(OCL(INDEX,0),U,4),"."),"2Z")
SET DATA=$$SETSTR(X,DATA,COL(3),$LENGTH(X))
End DoDot:2
+53 ; add data to output
+54 if DATA'=""
DO ADD(.TARGET,$$TRIM^XLFSTR(DATA,"R"))
End DoDot:1
+55 ; add indication if needed
+56 IF 'IND(0)
IF IND'=""
SET TEMP="Indication: "_IND
KILL TIUFT
DO WRAP^TIUFLD(TEMP,COL(1,"W"))
Begin DoDot:1
+57 SET X=0
FOR
SET X=$ORDER(TIUFT(X))
if 'X
QUIT
DO ADD(.TARGET,$$SETSTR(TIUFT(X),"",$SELECT(X=1:COL(1),1:COL(1)+2),$LENGTH(TIUFT(X))))
End DoDot:1
+58 QUIT
ADD(TARGET,DATA) ;
+1 SET @TARGET@(($ORDER(@TARGET@(""),-1)+1),0)=DATA
+2 QUIT
NODE(OCL,IDX,NODES) ;
+1 NEW DATA,NODE,X,Y
SET DATA=""
FOR X=1:1:$LENGTH(NODES,";")
SET NODE=$PIECE(NODES,";",X)
SET Y=0
FOR
SET Y=$ORDER(OCL(IDX,NODE,Y))
if 'Y
QUIT
SET DATA=DATA_$SELECT(DATA="":"",1:U)_$$TRIM^XLFSTR(OCL(IDX,NODE,Y,0))
+2 QUIT DATA
SETSTR(S,V,X,L) ;
+1 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
TITLE(TARGET,P,SHOW) ;
+1 NEW DATA
SET DATA=$SELECT('P("A"):"Active and Recently Expired ",P("A")=1:"Active ",1:"Recently Expired ")
+2 SET DATA=DATA_$SELECT('P("M"):$SELECT(P("INP"):"Inpatient ",1:"Outpatient "),P("M")=1:"Inpatient, Outpatient and Clinic ",P("M")=2:"Inpatient ",P("M")=3:"Outpatient ",1:"")
+3 SET DATA=DATA_$SELECT(P("M")=4:"Clinic ",P("M")=5:"Inpatient & Clinic ",P("M")=6:"Outpatient & Clinic ",1:"")_"Medications"_" ("_$SELECT(P("SU"):"in",1:"ex")_"cluding Supplies):"
+4 NEW TIUFT
DO WRAP^TIUFLD(DATA,80)
SET TIUFT=0
FOR
SET TIUFT=$ORDER(TIUFT(TIUFT))
if 'TIUFT
QUIT
DO ADD(.TARGET,TIUFT(TIUFT))
if '$ORDER(TIUFT(TIUFT))
DO ADD(.TARGET," ")
+5 IF SHOW
IF P("SC")
DO ADD(.TARGET," WARNING Sorting by drug class may be inaccurate.")
Begin DoDot:1
+6 DO ADD(.TARGET,"Multi-classed medications will only be displayed under a single drug class.")
IF 'P("UNK")
DO ADD(.TARGET," ")
End DoDot:1
+7 IF P("UNK")
DO ADD(.TARGET,"The system may not be able to determine the drug class of some medications.")
DO ADD(.TARGET," ")
+8 QUIT
UP(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+1 ;
