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

BTIUMED7.m

Go to the documentation of this file.
  1. BTIUMED7 ; SLC/JM - Active/Recent Med Objects Routine ;03-Oct-2012 14:44;DU
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**1010**;Jun 20, 1997;Build 24
  1. Q
  1. VMED(TARGET,FILLS) ;EP; returns medications for current vuecentric visit context
  1. ; If SIG is set to 1, include medication sig
  1. I $T(GETVAR^CIAVMEVT)="" S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)
  1. NEW VST,I,X,CNT,RESULT
  1. S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
  1. I VST="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
  1. S X="BEHOENCX" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^BEHOENCX(DFN,VST) I VST<1 S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
  1. ;S X="CIAVCXEN" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^CIAVCXEN(DFN,VST) I VST<1 Q
  1. D GETMED(.RESULT,VST)
  1. ;
  1. K @TARGET S CNT=0
  1. S I=0 F S I=$O(RESULT(I)) Q:'I D
  1. .S CNT=CNT+1
  1. .S @TARGET@(CNT,0)=RESULT(I)
  1. I 'CNT S @TARGET@(1,0)="No Medications Found for Visit"
  1. Q "~@"_$NA(@TARGET)
  1. ;
  1. GETMED(RETURN,VIEN) ;EP returns all medications given for a visit
  1. NEW TIUX,TIUY,COUNT,TIUIS,TIULF,TIUPRV,TIURE,TIURF,RXNO,RX,TRM
  1. K RETURN
  1. S COUNT=0
  1. S TIUX=0,TIUY="" F S TIUX=$O(^AUPNVMED("AD",VIEN,TIUX)) Q:'TIUX D
  1. . S TIUY=$$GET1^DIQ(9000010.14,TIUX,.01)
  1. . S RXNO=$$GET1^DIQ(9000010.14,TIUX,1102)
  1. . S RX="" S RX=$O(^PSRX("B",RXNO,RX))
  1. . I +RX D
  1. ..Q:+$$GET1^DIQ(52,RX,9999999.23) ;Quit if autofinished
  1. ..S TIUIS=$$GET1^DIQ(52,RX,1)
  1. ..S TIULF=$$GET1^DIQ(52,RX,101)
  1. ..S TIUPRV=$$GET1^DIQ(52,RX,4)
  1. ..S TRM=0
  1. ..F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S TRM=TRM+1
  1. ..S TIURF=$P($G(^PSRX(RX,0)),"^",9)-TRM
  1. ..I COUNT>0 S COUNT=COUNT+1 S RETURN(COUNT)=""
  1. ..S COUNT=COUNT+1
  1. ..S RETURN(COUNT)=TIUY
  1. ..S COUNT=COUNT+1
  1. ..S RETURN(COUNT)="Issue: "_TIUIS_" Last Fill: "_TIULF
  1. ..S COUNT=COUNT+1
  1. ..S RETURN(COUNT)="Refills Left: "_TIURF_" Provider: "_TIUPRV
  1. ..I $G(FILLS) D FILLS(.RETURN,VIEN)
  1. Q
  1. FILLS(RETURN,VIEN) ;Create and add nodes for fills and past fills.
  1. ;$G(^TMP("PS",$J,INDEX,0))
  1. K FILL
  1. N RFS,RF,RX2,RFL,FILL,II,PSIII,X,Y,Z,NRXN
  1. S RX2=$S($D(^PSRX(RX,2)):^PSRX(RX,2),1:"")
  1. S RFL=1
  1. D FILOOP(RX,RX2)
  1. S Y=""
  1. F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII D
  1. .S X=$P($G(FILL(PSIII)),U,1)
  1. .I X=0 Q
  1. .S Z=$$FMTE^XLFDT(X)
  1. .I Y="" S Y=Z
  1. .E S Y=Y_", "_Z
  1. I Y'="" D
  1. .S COUNT=COUNT+1
  1. .S RETURN(COUNT)="Previous fills:"
  1. .S COUNT=COUNT+1
  1. .S RETURN(COUNT)=" "_Y
  1. I RFL<6 D
  1. .K FILL
  1. .S Y=""
  1. .S NRXN=$P($G(^PSRX(RX,"OR1")),U,3)
  1. .I NRXN'="" D
  1. ..S RX2=$S($D(^PSRX(NRXN,2)):^PSRX(NRXN,2),1:"")
  1. ..D FILOOP(NRXN,RX2)
  1. ..F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII D
  1. ...S X=$P($G(FILL(PSIII)),U,1)
  1. ...I X=0 Q
  1. ...S Z=$$FMTE^XLFDT(X)
  1. ...I Y="" S Y=Z
  1. ...E S Y=Y_", "_Z
  1. I Y'="" D
  1. .S COUNT=COUNT+1
  1. .S RETURN(COUNT)="Past fills:"
  1. .S COUNT=COUNT+1
  1. .S RETURN(COUNT)=" "_Y
  1. Q
  1. FILOOP(RX,RX2) ;
  1. S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P($G(^PSRX(RX,0)),"^",9)
  1. F II=0:0 S II=$O(^PSRX(RX,1,II)) Q:'II S FILL(9999999-^PSRX(RX,1,II,0))=+^PSRX(RX,1,II,0)_"^"_$S($P(^(0),"^",16):"(R)",1:"") S RFL=RFL+1
  1. Q
  1. ;