Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIULMED

TIULMED.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to *^XLFDT in ICR #10103
  1. ; Reference to ISCLORD^ORUTL in ICR #7357
  1. ; Reference to *^XPDUTL in ICR #10141
  1. ; Reference to PEN^PSO5241 in ICR #4821
  1. ; Reference to RX^PSO52API in ICR #4820
  1. ; Reference to OCL^PSOORRL in ICR #2400
  1. ; Reference to OCL^PSOQ0496 in ICR #5197
  1. ; Reference to DRGIEN^PSS50P7 in ICR #4662
  1. ; Reference to *^PSS55 in ICR #4826
  1. ; Reference to ^PS(53.1 in ICR #2907
  1. ;
  1. Q
  1. LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ;
  1. ; This is the TIU Medication objects API. Optional parameters not
  1. ; provided default to 0 (with the exception of SUPPLIES).
  1. ;Required Parameters:
  1. ; DFN Patient identifier
  1. ; TARGET Where the medication data will be stored
  1. ;Optional Parameters:
  1. ; ACTVONLY 0 - Active and recently expired meds
  1. ; 1 - Active meds only
  1. ; 2 - Recently expired meds only
  1. ; DETAILED 0 - One line per med only
  1. ; 1 - Detailed information on each med
  1. ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an
  1. ; Inpatient, or Outpatient Meds if patient
  1. ; is an Outpatient
  1. ; 1 - Specifies Inpatient, Outpatient, & Clinic
  1. ; 2 or "I" - Specifies Inpatient only
  1. ; 3 or "O" - Specifies Outpatient only
  1. ; 4 or "C" - Specifies Clinic only
  1. ; 5 or "CI" or "IC" - Specifies Clinic and Inpatient Only
  1. ; 6 or "CO" or "OC" - Specifies Clinic and Outpatient Only
  1. ; ONELIST 0 - Separates Active, Pending and Inactive
  1. ; medications into separate lists
  1. ; 1 - Combines Active, Pending and Inactive
  1. ; medications into the same list
  1. ; CLASSORT 0 - Sort meds alphabetically
  1. ; 1 - Sort meds by drug class, and within the
  1. ; same drug class, sort alphabetically
  1. ; 2 - Same as #1, but show drug class in header
  1. ; SUPPLIES 0 - Supplies are excluded
  1. ; 1 - Supplies are included (Default)
  1. N XPARSYS I $$GET^XPAR("SYS","TIUMOBJ STATUS") D Q TARGET ; ajb *365 redirect on param def.
  1. . S TARGET=$$LIST^TIUMOBJ(DFN,.TARGET,$G(ACTVONLY),$G(DETAILED),$G(ALLMEDS),$G(ONELIST),$G(CLASSORT),$G(SUPPLIES))
  1. ; variables left after external calls *365
  1. N %H,BDT1,D0,DIQ2,DRG,GP,IEN,LSTDS,LSTFD,LSTRD,ND2P5,PSSTMP2,RNWDT,SG
  1. ;
  1. N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK
  1. N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN
  1. N SPACE60,DASH73,LINE,TAB,HEADER
  1. N DRUGCLAS,DRUGIDX,UNKNOWNS,CLINORD
  1. N NVATYPE,NVAMED,NVASTR,TIUXSTAT
  1. N %,%H,STOP,LSTFD ;Clean up after external calls...
  1. S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47
  1. S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="
  1. K @TARGET,^TMP("PS",$J)
  1. ; Check for Pharmacy Package and required patches
  1. I '$$PATCHSOK^TIULMED3 G LISTX ;P213
  1. I '+$G(ACTVONLY) S ACTVONLY=0
  1. I '+$G(DETAILED) S DETAILED=0
  1. I +$D(ALLMEDS) D
  1. .I ALLMEDS="I" S ALLMEDS=2
  1. .E I ALLMEDS="O" S ALLMEDS=3
  1. .E I ALLMEDS="C" S ALLMEDS=4 ; ajb 290
  1. .E I ALLMEDS="CI"!(ALLMEDS="IC") S ALLMEDS=5 ; ajb 290
  1. .E I ALLMEDS="CO"!(ALLMEDS="OC") S ALLMEDS=6 ; ajb 290
  1. I '+$G(ALLMEDS) S ALLMEDS=0
  1. I '+$G(ONELIST) S ONELIST=0
  1. I '+$G(CLASSORT) S CLASSORT=0
  1. I $G(SUPPLIES)'="0" S SUPPLIES=1
  1. S (EMPTY,HEADER)=1
  1. I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT S HEADER=0
  1. I 'DETAILED S LLEN=60
  1. ;COMMENTED OUT THE FOLLOWING LINE OF CODE IN FAVOUR OF THE NEXT LINE OF PAPI CODE
  1. ;S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^"
  1. S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^ACTIVE/PARKED^"
  1. S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
  1. S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient? IA 10035
  1. I ISINP S INPTYPE=1,OUTPTYPE=2
  1. E S INPTYPE=2,OUTPTYPE=1
  1. S NVATYPE=3
  1. D ADDTITLE^TIULMED1
  1. ;
  1. ; *** Scan medication data and skip unwanted meds ***
  1. ; Changes for *238 required by PSO*7*294
  1. D
  1. . I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE) S TIUDATE=$$FMADD^XLFDT(DT,-$G(TIUDATE)) D OCL^PSOQ0496(DFN,TIUDATE,"") Q ; IA 2400
  1. . D OCL^PSOORRL(DFN,"","") ; IA 2400
  1. ;
  1. S INDEX=0
  1. F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
  1. .S NODE=$G(^TMP("PS",$J,INDEX,0))
  1. .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
  1. .I KEEPMED D
  1. ..;ajb 290 check if clinic order
  1. .. S CLINORD=0
  1. .. D ISCLORD^ORUTL(.CLINORD,$P(NODE,U,8))
  1. ..;ajb 290
  1. ..S STATUS=$P(NODE,U,9)
  1. ..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)"
  1. ..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1
  1. ..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2
  1. ..E S STATIDX=3
  1. ..S TIUXSTAT=STATUS
  1. ..I ACTVONLY=1 S KEEPMED=(STATIDX<3)
  1. ..I ACTVONLY=2 S KEEPMED=(STATIDX=3)
  1. ..I +ONELIST S STATIDX=1
  1. ..; Changes for *238 required by PSO*7*294
  1. ..I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE),STATUS["DISCONTINUED" S KEEPMED=0
  1. .I KEEPMED D
  1. ..S TYPE=$P($P(NODE,U),";",2)
  1. ..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
  1. ..S NVAMED=$P($P(NODE,U),";")
  1. ..S NVAMED=$E(NVAMED,$L(NVAMED))
  1. ..S KEEPMED=(TYPE'="")
  1. .I KEEPMED D
  1. ..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV"
  1. ..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV"
  1. ..I TYPE="OP" S MEDTYPE=OUTPTYPE
  1. ..E S MEDTYPE=INPTYPE
  1. ..I NVAMED="N" S MEDTYPE=NVATYPE
  1. ..I ALLMEDS=0 D I 1
  1. ...I MEDTYPE=INPTYPE S KEEPMED=ISINP
  1. ...E S KEEPMED='ISINP
  1. ...I +CLINORD S KEEPMED=0 ; ajb 290 check to see if clinic meds
  1. ..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE) I +CLINORD S KEEPMED=0 ; inpatient only
  1. ..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE)) I +CLINORD S KEEPMED=0 ; outpatient only
  1. ..E I ALLMEDS=4,'+CLINORD S KEEPMED=0 ; clinic only
  1. ..E I ALLMEDS=5 S KEEPMED=0 I +CLINORD!(MEDTYPE=INPTYPE) S KEEPMED=1 ; clinic & inpatient
  1. ..E I ALLMEDS=6 S KEEPMED=0 I +CLINORD!(MEDTYPE=OUTPTYPE)!(MEDTYPE=NVATYPE) S KEEPMED=1 ; clinic & outpatient/non-va *365
  1. .S DRUGCLAS=" "
  1. .S MED=$P(NODE,U,2)
  1. .I KEEPMED,(CLASSORT!('SUPPLIES)) D
  1. ..S DRUGIDX=$$IENNAME^TIULMED2(MED)
  1. ..D GETCLASS
  1. .. ; If DRUGIDX="" (MED not in Drug File 50), get info
  1. .. ; via Orderable Item instead.
  1. ..I KEEPMED,+DRUGIDX=0 D
  1. ...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
  1. ...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
  1. ...S (DRUGIDX,ORDIDX)=0
  1. ...K ^TMP($J,"TIULMED")
  1. ...; IDX is Order #; ID indicates what file. See IA 2400
  1. ...; R;O MED will always be in Drug File (Unless Drug File entry was
  1. ...; changed after ordering.
  1. ...I ID="R;O" D ;R;O = prescription (file #52). P213
  1. ....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820
  1. ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6))
  1. ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI"))
  1. ...;
  1. ...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213
  1. ....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821
  1. ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11))
  1. ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8))
  1. ...;
  1. ...I ID="P;I" D ;P;I = pending inpatient order (file #53.1)
  1. ....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D ; IA 2907
  1. .....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D
  1. ......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U)
  1. ....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U)
  1. ...;
  1. ...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213
  1. ....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826
  1. ....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D
  1. .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0
  1. .....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
  1. .....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108))
  1. ...;
  1. ...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213
  1. ....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826
  1. ....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
  1. ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130))
  1. ....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D
  1. .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D
  1. ......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01))
  1. ......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662
  1. ...;
  1. ...S DRUGCLAS=""
  1. ...D GETCLASS
  1. ...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D
  1. ....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES
  1. ....N LIST S LIST="TIULMED" K ^TMP($J,LIST)
  1. ....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662
  1. ....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE)
  1. .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
  1. .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
  1. .....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS=""
  1. .....I 'CDONE D
  1. ......I DRUGCLAS="" S DRUGCLAS=TMPCLASS
  1. ......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS=""
  1. .....I 'SDONE D
  1. ......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S"))
  1. ......I 'ISSUPPLY S SDONE=1
  1. ....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0
  1. ..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" "
  1. .;
  1. .; *** Save wanted meds in "B" temp xref, removing duplicates ***
  1. .;
  1. .I KEEPMED D
  1. ..D ADDMED^TIULMED1(1) ; Get XSTR to check for duplicates
  1. ..;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL
  1. ..S IDATE=$P(NODE,U,15)
  1. ..S OK='$D(@TARGET@("B",MED,XSTR,TIUXSTAT))
  1. ..I 'OK,(IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT)) S OK=1
  1. ..I OK D
  1. ...S @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS
  1. ...S EMPTY=0
  1. ...I DRUGCLAS=" " S UNKNOWNS=1
  1. ;
  1. D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213
  1. LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED"),TIUDATE ; K TIUDATE added for PSO*7*294
  1. Q "~@"_$NA(@TARGET)
  1. ;
  1. GETCLASS ;
  1. D GETCLASS^TIULMED3
  1. Q