- 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 Jan 18, 2025@03:43:24 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