TIULMED ; SLC/JM,JH,AJB - ACTIVE/RECENT MED OBJECTS ;Aug 02, 2024@13:53:02
;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213,238,290,289,318,365**;Jun 20, 1997;Build 1
;
; Reference to *^XLFDT in ICR #10103
; Reference to ISCLORD^ORUTL in ICR #7357
; Reference to *^XPDUTL in ICR #10141
; Reference to PEN^PSO5241 in ICR #4821
; Reference to RX^PSO52API in ICR #4820
; Reference to OCL^PSOORRL in ICR #2400
; Reference to OCL^PSOQ0496 in ICR #5197
; Reference to DRGIEN^PSS50P7 in ICR #4662
; Reference to *^PSS55 in ICR #4826
; Reference to ^PS(53.1 in ICR #2907
;
Q
LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ;
; This is the TIU Medication objects API. Optional parameters not
; provided default to 0 (with the exception of SUPPLIES).
;Required Parameters:
; DFN Patient identifier
; TARGET Where the medication data will be stored
;Optional Parameters:
; ACTVONLY 0 - Active and recently expired meds
; 1 - Active meds only
; 2 - Recently expired meds only
; DETAILED 0 - One line per med only
; 1 - Detailed information on each med
; ALLMEDS 0 - Specifies Inpatient Meds if patient is an
; Inpatient, or Outpatient Meds if patient
; is an Outpatient
; 1 - Specifies Inpatient, Outpatient, & Clinic
; 2 or "I" - Specifies Inpatient only
; 3 or "O" - Specifies Outpatient only
; 4 or "C" - Specifies Clinic only
; 5 or "CI" or "IC" - Specifies Clinic and Inpatient Only
; 6 or "CO" or "OC" - Specifies Clinic and Outpatient Only
; ONELIST 0 - Separates Active, Pending and Inactive
; medications into separate lists
; 1 - Combines Active, Pending and Inactive
; medications into the same list
; CLASSORT 0 - Sort meds alphabetically
; 1 - Sort meds by drug class, and within the
; same drug class, sort alphabetically
; 2 - Same as #1, but show drug class in header
; SUPPLIES 0 - Supplies are excluded
; 1 - Supplies are included (Default)
N XPARSYS I $$GET^XPAR("SYS","TIUMOBJ STATUS") D Q TARGET ; ajb *365 redirect on param def.
. S TARGET=$$LIST^TIUMOBJ(DFN,.TARGET,$G(ACTVONLY),$G(DETAILED),$G(ALLMEDS),$G(ONELIST),$G(CLASSORT),$G(SUPPLIES))
; variables left after external calls *365
N %H,BDT1,D0,DIQ2,DRG,GP,IEN,LSTDS,LSTFD,LSTRD,ND2P5,PSSTMP2,RNWDT,SG
;
N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK
N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN
N SPACE60,DASH73,LINE,TAB,HEADER
N DRUGCLAS,DRUGIDX,UNKNOWNS,CLINORD
N NVATYPE,NVAMED,NVASTR,TIUXSTAT
N %,%H,STOP,LSTFD ;Clean up after external calls...
S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47
S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="
K @TARGET,^TMP("PS",$J)
; Check for Pharmacy Package and required patches
I '$$PATCHSOK^TIULMED3 G LISTX ;P213
I '+$G(ACTVONLY) S ACTVONLY=0
I '+$G(DETAILED) S DETAILED=0
I +$D(ALLMEDS) D
.I ALLMEDS="I" S ALLMEDS=2
.E I ALLMEDS="O" S ALLMEDS=3
.E I ALLMEDS="C" S ALLMEDS=4 ; ajb 290
.E I ALLMEDS="CI"!(ALLMEDS="IC") S ALLMEDS=5 ; ajb 290
.E I ALLMEDS="CO"!(ALLMEDS="OC") S ALLMEDS=6 ; ajb 290
I '+$G(ALLMEDS) S ALLMEDS=0
I '+$G(ONELIST) S ONELIST=0
I '+$G(CLASSORT) S CLASSORT=0
I $G(SUPPLIES)'="0" S SUPPLIES=1
S (EMPTY,HEADER)=1
I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT S HEADER=0
I 'DETAILED S LLEN=60
;COMMENTED OUT THE FOLLOWING LINE OF CODE IN FAVOUR OF THE NEXT LINE OF PAPI CODE
;S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^"
S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^ACTIVE/PARKED^"
S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient? IA 10035
I ISINP S INPTYPE=1,OUTPTYPE=2
E S INPTYPE=2,OUTPTYPE=1
S NVATYPE=3
D ADDTITLE^TIULMED1
;
; *** Scan medication data and skip unwanted meds ***
; Changes for *238 required by PSO*7*294
D
. I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE) S TIUDATE=$$FMADD^XLFDT(DT,-$G(TIUDATE)) D OCL^PSOQ0496(DFN,TIUDATE,"") Q ; IA 2400
. D OCL^PSOORRL(DFN,"","") ; IA 2400
;
S INDEX=0
F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
.S NODE=$G(^TMP("PS",$J,INDEX,0))
.S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
.I KEEPMED D
..;ajb 290 check if clinic order
.. S CLINORD=0
.. D ISCLORD^ORUTL(.CLINORD,$P(NODE,U,8))
..;ajb 290
..S STATUS=$P(NODE,U,9)
..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)"
..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1
..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2
..E S STATIDX=3
..S TIUXSTAT=STATUS
..I ACTVONLY=1 S KEEPMED=(STATIDX<3)
..I ACTVONLY=2 S KEEPMED=(STATIDX=3)
..I +ONELIST S STATIDX=1
..; Changes for *238 required by PSO*7*294
..I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE),STATUS["DISCONTINUED" S KEEPMED=0
.I KEEPMED D
..S TYPE=$P($P(NODE,U),";",2)
..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
..S NVAMED=$P($P(NODE,U),";")
..S NVAMED=$E(NVAMED,$L(NVAMED))
..S KEEPMED=(TYPE'="")
.I KEEPMED D
..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV"
..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV"
..I TYPE="OP" S MEDTYPE=OUTPTYPE
..E S MEDTYPE=INPTYPE
..I NVAMED="N" S MEDTYPE=NVATYPE
..I ALLMEDS=0 D I 1
...I MEDTYPE=INPTYPE S KEEPMED=ISINP
...E S KEEPMED='ISINP
...I +CLINORD S KEEPMED=0 ; ajb 290 check to see if clinic meds
..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE) I +CLINORD S KEEPMED=0 ; inpatient only
..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE)) I +CLINORD S KEEPMED=0 ; outpatient only
..E I ALLMEDS=4,'+CLINORD S KEEPMED=0 ; clinic only
..E I ALLMEDS=5 S KEEPMED=0 I +CLINORD!(MEDTYPE=INPTYPE) S KEEPMED=1 ; clinic & inpatient
..E I ALLMEDS=6 S KEEPMED=0 I +CLINORD!(MEDTYPE=OUTPTYPE)!(MEDTYPE=NVATYPE) S KEEPMED=1 ; clinic & outpatient/non-va *365
.S DRUGCLAS=" "
.S MED=$P(NODE,U,2)
.I KEEPMED,(CLASSORT!('SUPPLIES)) D
..S DRUGIDX=$$IENNAME^TIULMED2(MED)
..D GETCLASS
.. ; If DRUGIDX="" (MED not in Drug File 50), get info
.. ; via Orderable Item instead.
..I KEEPMED,+DRUGIDX=0 D
...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
...S (DRUGIDX,ORDIDX)=0
...K ^TMP($J,"TIULMED")
...; IDX is Order #; ID indicates what file. See IA 2400
...; R;O MED will always be in Drug File (Unless Drug File entry was
...; changed after ordering.
...I ID="R;O" D ;R;O = prescription (file #52). P213
....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820
....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6))
....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI"))
...;
...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213
....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821
....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11))
....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8))
...;
...I ID="P;I" D ;P;I = pending inpatient order (file #53.1)
....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D ; IA 2907
.....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D
......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U)
....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U)
...;
...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213
....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826
....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D
.....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0
.....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
.....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108))
...;
...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213
....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826
....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130))
....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D
.....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D
......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01))
......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662
...;
...S DRUGCLAS=""
...D GETCLASS
...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D
....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES
....N LIST S LIST="TIULMED" K ^TMP($J,LIST)
....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662
....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE)
.....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
.....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
.....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS=""
.....I 'CDONE D
......I DRUGCLAS="" S DRUGCLAS=TMPCLASS
......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS=""
.....I 'SDONE D
......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S"))
......I 'ISSUPPLY S SDONE=1
....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0
..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" "
.;
.; *** Save wanted meds in "B" temp xref, removing duplicates ***
.;
.I KEEPMED D
..D ADDMED^TIULMED1(1) ; Get XSTR to check for duplicates
..;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL
..S IDATE=$P(NODE,U,15)
..S OK='$D(@TARGET@("B",MED,XSTR,TIUXSTAT))
..I 'OK,(IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT)) S OK=1
..I OK D
...S @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS
...S EMPTY=0
...I DRUGCLAS=" " S UNKNOWNS=1
;
D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213
LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED"),TIUDATE ; K TIUDATE added for PSO*7*294
Q "~@"_$NA(@TARGET)
;
GETCLASS ;
D GETCLASS^TIULMED3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULMED 9692 printed Dec 13, 2024@02:42:15 Page 2
TIULMED ; SLC/JM,JH,AJB - ACTIVE/RECENT MED OBJECTS ;Aug 02, 2024@13:53:02
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213,238,290,289,318,365**;Jun 20, 1997;Build 1
+2 ;
+3 ; Reference to *^XLFDT in ICR #10103
+4 ; Reference to ISCLORD^ORUTL in ICR #7357
+5 ; Reference to *^XPDUTL in ICR #10141
+6 ; Reference to PEN^PSO5241 in ICR #4821
+7 ; Reference to RX^PSO52API in ICR #4820
+8 ; Reference to OCL^PSOORRL in ICR #2400
+9 ; Reference to OCL^PSOQ0496 in ICR #5197
+10 ; Reference to DRGIEN^PSS50P7 in ICR #4662
+11 ; Reference to *^PSS55 in ICR #4826
+12 ; Reference to ^PS(53.1 in ICR #2907
+13 ;
+14 QUIT
LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ;
+1 ; This is the TIU Medication objects API. Optional parameters not
+2 ; provided default to 0 (with the exception of SUPPLIES).
+3 ;Required Parameters:
+4 ; DFN Patient identifier
+5 ; TARGET Where the medication data will be stored
+6 ;Optional Parameters:
+7 ; ACTVONLY 0 - Active and recently expired meds
+8 ; 1 - Active meds only
+9 ; 2 - Recently expired meds only
+10 ; DETAILED 0 - One line per med only
+11 ; 1 - Detailed information on each med
+12 ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an
+13 ; Inpatient, or Outpatient Meds if patient
+14 ; is an Outpatient
+15 ; 1 - Specifies Inpatient, Outpatient, & Clinic
+16 ; 2 or "I" - Specifies Inpatient only
+17 ; 3 or "O" - Specifies Outpatient only
+18 ; 4 or "C" - Specifies Clinic only
+19 ; 5 or "CI" or "IC" - Specifies Clinic and Inpatient Only
+20 ; 6 or "CO" or "OC" - Specifies Clinic and Outpatient Only
+21 ; ONELIST 0 - Separates Active, Pending and Inactive
+22 ; medications into separate lists
+23 ; 1 - Combines Active, Pending and Inactive
+24 ; medications into the same list
+25 ; CLASSORT 0 - Sort meds alphabetically
+26 ; 1 - Sort meds by drug class, and within the
+27 ; same drug class, sort alphabetically
+28 ; 2 - Same as #1, but show drug class in header
+29 ; SUPPLIES 0 - Supplies are excluded
+30 ; 1 - Supplies are included (Default)
+31 ; ajb *365 redirect on param def.
NEW XPARSYS
IF $$GET^XPAR("SYS","TIUMOBJ STATUS")
Begin DoDot:1
+32 SET TARGET=$$LIST^TIUMOBJ(DFN,.TARGET,$GET(ACTVONLY),$GET(DETAILED),$GET(ALLMEDS),$GET(ONELIST),$GET(CLASSORT),$GET(SUPPLIES))
End DoDot:1
QUIT TARGET
+33 ; variables left after external calls *365
+34 NEW %H,BDT1,D0,DIQ2,DRG,GP,IEN,LSTDS,LSTFD,LSTRD,ND2P5,PSSTMP2,RNWDT,SG
+35 ;
+36 NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK
+37 NEW STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN
+38 NEW SPACE60,DASH73,LINE,TAB,HEADER
+39 NEW DRUGCLAS,DRUGIDX,UNKNOWNS,CLINORD
+40 NEW NVATYPE,NVAMED,NVASTR,TIUXSTAT
+41 ;Clean up after external calls...
NEW %,%H,STOP,LSTFD
+42 SET (NEXTLINE,TAB,HEADER,UNKNOWNS)=0
SET LLEN=47
+43 SET $PIECE(SPACE60," ",60)=" "
SET $PIECE(DASH73,"=",73)="="
+44 KILL @TARGET,^TMP("PS",$JOB)
+45 ; Check for Pharmacy Package and required patches
+46 ;P213
IF '$$PATCHSOK^TIULMED3
GOTO LISTX
+47 IF '+$GET(ACTVONLY)
SET ACTVONLY=0
+48 IF '+$GET(DETAILED)
SET DETAILED=0
+49 IF +$DATA(ALLMEDS)
Begin DoDot:1
+50 IF ALLMEDS="I"
SET ALLMEDS=2
+51 IF '$TEST
IF ALLMEDS="O"
SET ALLMEDS=3
+52 ; ajb 290
IF '$TEST
IF ALLMEDS="C"
SET ALLMEDS=4
+53 ; ajb 290
IF '$TEST
IF ALLMEDS="CI"!(ALLMEDS="IC")
SET ALLMEDS=5
+54 ; ajb 290
IF '$TEST
IF ALLMEDS="CO"!(ALLMEDS="OC")
SET ALLMEDS=6
End DoDot:1
+55 IF '+$GET(ALLMEDS)
SET ALLMEDS=0
+56 IF '+$GET(ONELIST)
SET ONELIST=0
+57 IF '+$GET(CLASSORT)
SET CLASSORT=0
+58 IF $GET(SUPPLIES)'="0"
SET SUPPLIES=1
+59 SET (EMPTY,HEADER)=1
+60 IF ONELIST
IF 'ALLMEDS
IF 'DETAILED
IF 'CLASSORT
SET HEADER=0
+61 IF 'DETAILED
SET LLEN=60
+62 ;COMMENTED OUT THE FOLLOWING LINE OF CODE IN FAVOUR OF THE NEXT LINE OF PAPI CODE
+63 ;S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^"
+64 SET ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^ACTIVE/PARKED^"
+65 SET PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
+66 ; Is this an inpatient? IA 10035
SET ISINP=($GET(^DPT(DFN,.1))'="")
+67 IF ISINP
SET INPTYPE=1
SET OUTPTYPE=2
+68 IF '$TEST
SET INPTYPE=2
SET OUTPTYPE=1
+69 SET NVATYPE=3
+70 DO ADDTITLE^TIULMED1
+71 ;
+72 ; *** Scan medication data and skip unwanted meds ***
+73 ; Changes for *238 required by PSO*7*294
+74 Begin DoDot:1
+75 ; IA 2400
IF $$PATCH^XPDUTL("PSO*7.0*294")
IF +$DATA(TIUDATE)
SET TIUDATE=$$FMADD^XLFDT(DT,-$GET(TIUDATE))
DO OCL^PSOQ0496(DFN,TIUDATE,"")
QUIT
+76 ; IA 2400
DO OCL^PSOORRL(DFN,"","")
End DoDot:1
+77 ;
+78 SET INDEX=0
+79 FOR
SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX))
if INDEX'>0
QUIT
Begin DoDot:1
+80 SET NODE=$GET(^TMP("PS",$JOB,INDEX,0))
+81 ;Discard Blank Meds
SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)
+82 IF KEEPMED
Begin DoDot:2
+83 ;ajb 290 check if clinic order
+84 SET CLINORD=0
+85 DO ISCLORD^ORUTL(.CLINORD,$PIECE(NODE,U,8))
+86 ;ajb 290
+87 SET STATUS=$PIECE(NODE,U,9)
+88 IF STATUS="ACTIVE/SUSP"
SET STATUS="ACTIVE (S)"
+89 IF $FIND(ASTATS,"^"_STATUS_"^")>0
SET STATIDX=1
+90 IF '$TEST
IF ($FIND(PSTATS,"^"_STATUS_"^")>0)
SET STATIDX=2
+91 IF '$TEST
SET STATIDX=3
+92 SET TIUXSTAT=STATUS
+93 IF ACTVONLY=1
SET KEEPMED=(STATIDX<3)
+94 IF ACTVONLY=2
SET KEEPMED=(STATIDX=3)
+95 IF +ONELIST
SET STATIDX=1
+96 ; Changes for *238 required by PSO*7*294
+97 IF $$PATCH^XPDUTL("PSO*7.0*294")
IF +$DATA(TIUDATE)
IF STATUS["DISCONTINUED"
SET KEEPMED=0
End DoDot:2
+98 IF KEEPMED
Begin DoDot:2
+99 SET TYPE=$PIECE($PIECE(NODE,U),";",2)
+100 SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")
+101 SET NVAMED=$PIECE($PIECE(NODE,U),";")
+102 SET NVAMED=$EXTRACT(NVAMED,$LENGTH(NVAMED))
+103 SET KEEPMED=(TYPE'="")
End DoDot:2
+104 IF KEEPMED
Begin DoDot:2
+105 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
SET TYPE="IV"
+106 IF '$TEST
IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
SET TYPE="IV"
+107 IF TYPE="OP"
SET MEDTYPE=OUTPTYPE
+108 IF '$TEST
SET MEDTYPE=INPTYPE
+109 IF NVAMED="N"
SET MEDTYPE=NVATYPE
+110 IF ALLMEDS=0
Begin DoDot:3
+111 IF MEDTYPE=INPTYPE
SET KEEPMED=ISINP
+112 IF '$TEST
SET KEEPMED='ISINP
+113 ; ajb 290 check to see if clinic meds
IF +CLINORD
SET KEEPMED=0
End DoDot:3
IF 1
+114 ; inpatient only
IF '$TEST
IF ALLMEDS=2
SET KEEPMED=(MEDTYPE=INPTYPE)
IF +CLINORD
SET KEEPMED=0
+115 ; outpatient only
IF '$TEST
IF ALLMEDS=3
SET KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE))
IF +CLINORD
SET KEEPMED=0
+116 ; clinic only
IF '$TEST
IF ALLMEDS=4
IF '+CLINORD
SET KEEPMED=0
+117 ; clinic & inpatient
IF '$TEST
IF ALLMEDS=5
SET KEEPMED=0
IF +CLINORD!(MEDTYPE=INPTYPE)
SET KEEPMED=1
+118 ; clinic & outpatient/non-va *365
IF '$TEST
IF ALLMEDS=6
SET KEEPMED=0
IF +CLINORD!(MEDTYPE=OUTPTYPE)!(MEDTYPE=NVATYPE)
SET KEEPMED=1
End DoDot:2
+119 SET DRUGCLAS=" "
+120 SET MED=$PIECE(NODE,U,2)
+121 IF KEEPMED
IF (CLASSORT!('SUPPLIES))
Begin DoDot:2
+122 SET DRUGIDX=$$IENNAME^TIULMED2(MED)
+123 DO GETCLASS
+124 ; If DRUGIDX="" (MED not in Drug File 50), get info
+125 ; via Orderable Item instead.
+126 IF KEEPMED
IF +DRUGIDX=0
Begin DoDot:3
+127 NEW IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
+128 SET ID=$PIECE(NODE,U)
SET IDX=+ID
SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
+129 SET (DRUGIDX,ORDIDX)=0
+130 KILL ^TMP($JOB,"TIULMED")
+131 ; IDX is Order #; ID indicates what file. See IA 2400
+132 ; R;O MED will always be in Drug File (Unless Drug File entry was
+133 ; changed after ordering.
+134 ;R;O = prescription (file #52). P213
IF ID="R;O"
Begin DoDot:4
+135 ; IA 4820
DO RX^PSO52API(DFN,"TIULMED",IDX,"","0,O")
+136 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,6))
+137 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,"OI"))
End DoDot:4
+138 ;
+139 ;P;O = pending outpatient order (file #52.41). P213
IF ID="P;O"
Begin DoDot:4
+140 ; IA 4821
DO PEN^PSO5241(DFN,"TIULMED",IDX)
+141 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,11))
+142 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,8))
End DoDot:4
+143 ;
+144 ;P;I = pending inpatient order (file #53.1)
IF ID="P;I"
Begin DoDot:4
+145 ; IA 2907
IF $PIECE($GET(^PS(53.1,IDX,1,0)),U,4)=1
Begin DoDot:5
+146 SET TMPIDX=$ORDER(^PS(53.1,IDX,1,0))
IF +TMPIDX
Begin DoDot:6
+147 SET DRUGIDX=$PIECE($GET(^PS(53.1,IDX,1,TMPIDX,0)),U)
End DoDot:6
End DoDot:5
+148 SET ORDIDX=+$PIECE($GET(^PS(53.1,IDX,.2)),U)
End DoDot:4
+149 ;
+150 ;U;I = unit dose order (file #55, subfile 55.06) P213
IF ID="U;I"
Begin DoDot:4
+151 ; IA 4826
DO PSS431^PSS55(DFN,IDX,"","","TIULMED")
+152 IF +$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))=1
Begin DoDot:5
+153 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))
if TMPIDX'>0
QUIT
+154 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
+155 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,108))
End DoDot:5
End DoDot:4
+156 ;
+157 ;V;I = IV order (file #55, subfile 55.01). P213
IF ID="V;I"
Begin DoDot:4
+158 ; IA 4826
DO PSS436^PSS55(DFN,IDX,"TIULMED")
+159 ; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
+160 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,130))
+161 IF ^TMP($JOB,"TIULMED",IDX,"ADD",0)=1
Begin DoDot:5
+162 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"ADD",0))
IF +TMPIDX
Begin DoDot:6
+163 SET TMPIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"ADD",TMPIDX,.01))
+164 ; IA 4662
IF +TMPIDX
SET DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX)
End DoDot:6
End DoDot:5
End DoDot:4
+165 ;
+166 SET DRUGCLAS=""
+167 DO GETCLASS
+168 IF KEEPMED
IF +DRUGIDX=0
IF +ORDIDX
IF DRUGCLAS=""
Begin DoDot:4
+169 SET IDX=0
SET ISSUPPLY=2
SET CDONE='CLASSORT
SET SDONE=+SUPPLIES
+170 NEW LIST
SET LIST="TIULMED"
KILL ^TMP($JOB,LIST)
+171 ; IA 4662
DO DRGIEN^PSS50P7(ORDIDX,"",LIST)
+172 FOR
SET IDX=$ORDER(^TMP($JOB,LIST,IDX))
if 'IDX
QUIT
Begin DoDot:5
+173 SET TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
+174 SET TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
+175 IF 'CDONE
IF TMPCLASS=""
SET CDONE=1
SET DRUGCLAS=""
+176 IF 'CDONE
Begin DoDot:6
+177 IF DRUGCLAS=""
SET DRUGCLAS=TMPCLASS
+178 IF '$TEST
IF DRUGCLAS'=TMPCLASS
SET CDONE=1
SET DRUGCLAS=""
End DoDot:6
+179 IF 'SDONE
Begin DoDot:6
+180 SET ISSUPPLY=(($EXTRACT(TMPCLASS,1,2)="XA")&($PIECE(TMPNODE,U,3)["S"))
+181 IF 'ISSUPPLY
SET SDONE=1
End DoDot:6
End DoDot:5
if (CDONE&SDONE)
QUIT
+182 IF 'SUPPLIES
IF (ISSUPPLY=1)
SET KEEPMED=0
End DoDot:4
End DoDot:3
+183 IF (DRUGCLAS="")!('CLASSORT)
SET DRUGCLAS=" "
End DoDot:2
+184 ;
+185 ; *** Save wanted meds in "B" temp xref, removing duplicates ***
+186 ;
+187 IF KEEPMED
Begin DoDot:2
+188 ; Get XSTR to check for duplicates
DO ADDMED^TIULMED1(1)
+189 ;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL
+190 SET IDATE=$PIECE(NODE,U,15)
+191 SET OK='$DATA(@TARGET@("B",MED,XSTR,TIUXSTAT))
+192 IF 'OK
IF (IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT))
SET OK=1
+193 IF OK
Begin DoDot:3
+194 SET @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS
+195 SET EMPTY=0
+196 IF DRUGCLAS=" "
SET UNKNOWNS=1
End DoDot:3
End DoDot:2
End DoDot:1
+197 ;
+198 ;P213
DO SORTSAVE^TIULMED3
KILL @TARGET@("B"),@TARGET@("C")
LISTX ; K TIUDATE added for PSO*7*294
KILL ^TMP("PS",$JOB),^TMP($JOB,"TIULMED"),TIUDATE
+1 QUIT "~@"_$NAME(@TARGET)
+2 ;
GETCLASS ;
+1 DO GETCLASS^TIULMED3
+2 QUIT
