BTIUMED7 ; SLC/JM - Active/Recent Med Objects Routine ;03-Oct-2012 14:44;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1010**;Jun 20, 1997;Build 24
Q
VMED(TARGET,FILLS) ;EP; returns medications for current vuecentric visit context
; If SIG is set to 1, include medication sig
I $T(GETVAR^CIAVMEVT)="" S @TARGET@(1,0)="Invalid context variables" Q "~@"_$NA(@TARGET)
NEW VST,I,X,CNT,RESULT
S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
I VST="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
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)
;S X="CIAVCXEN" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^CIAVCXEN(DFN,VST) I VST<1 Q
D GETMED(.RESULT,VST)
;
K @TARGET S CNT=0
S I=0 F S I=$O(RESULT(I)) Q:'I D
.S CNT=CNT+1
.S @TARGET@(CNT,0)=RESULT(I)
I 'CNT S @TARGET@(1,0)="No Medications Found for Visit"
Q "~@"_$NA(@TARGET)
;
GETMED(RETURN,VIEN) ;EP returns all medications given for a visit
NEW TIUX,TIUY,COUNT,TIUIS,TIULF,TIUPRV,TIURE,TIURF,RXNO,RX,TRM
K RETURN
S COUNT=0
S TIUX=0,TIUY="" F S TIUX=$O(^AUPNVMED("AD",VIEN,TIUX)) Q:'TIUX D
. S TIUY=$$GET1^DIQ(9000010.14,TIUX,.01)
. S RXNO=$$GET1^DIQ(9000010.14,TIUX,1102)
. S RX="" S RX=$O(^PSRX("B",RXNO,RX))
. I +RX D
..Q:+$$GET1^DIQ(52,RX,9999999.23) ;Quit if autofinished
..S TIUIS=$$GET1^DIQ(52,RX,1)
..S TIULF=$$GET1^DIQ(52,RX,101)
..S TIUPRV=$$GET1^DIQ(52,RX,4)
..S TRM=0
..F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S TRM=TRM+1
..S TIURF=$P($G(^PSRX(RX,0)),"^",9)-TRM
..I COUNT>0 S COUNT=COUNT+1 S RETURN(COUNT)=""
..S COUNT=COUNT+1
..S RETURN(COUNT)=TIUY
..S COUNT=COUNT+1
..S RETURN(COUNT)="Issue: "_TIUIS_" Last Fill: "_TIULF
..S COUNT=COUNT+1
..S RETURN(COUNT)="Refills Left: "_TIURF_" Provider: "_TIUPRV
..I $G(FILLS) D FILLS(.RETURN,VIEN)
Q
FILLS(RETURN,VIEN) ;Create and add nodes for fills and past fills.
;$G(^TMP("PS",$J,INDEX,0))
K FILL
N RFS,RF,RX2,RFL,FILL,II,PSIII,X,Y,Z,NRXN
S RX2=$S($D(^PSRX(RX,2)):^PSRX(RX,2),1:"")
S RFL=1
D FILOOP(RX,RX2)
S Y=""
F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII D
.S X=$P($G(FILL(PSIII)),U,1)
.I X=0 Q
.S Z=$$FMTE^XLFDT(X)
.I Y="" S Y=Z
.E S Y=Y_", "_Z
I Y'="" D
.S COUNT=COUNT+1
.S RETURN(COUNT)="Previous fills:"
.S COUNT=COUNT+1
.S RETURN(COUNT)=" "_Y
I RFL<6 D
.K FILL
.S Y=""
.S NRXN=$P($G(^PSRX(RX,"OR1")),U,3)
.I NRXN'="" D
..S RX2=$S($D(^PSRX(NRXN,2)):^PSRX(NRXN,2),1:"")
..D FILOOP(NRXN,RX2)
..F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII D
...S X=$P($G(FILL(PSIII)),U,1)
...I X=0 Q
...S Z=$$FMTE^XLFDT(X)
...I Y="" S Y=Z
...E S Y=Y_", "_Z
I Y'="" D
.S COUNT=COUNT+1
.S RETURN(COUNT)="Past fills:"
.S COUNT=COUNT+1
.S RETURN(COUNT)=" "_Y
Q
FILOOP(RX,RX2) ;
S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P($G(^PSRX(RX,0)),"^",9)
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
Q
;
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
+2 QUIT
VMED(TARGET,FILLS) ;EP; returns medications for current vuecentric visit context
+1 ; If SIG is set to 1, include medication sig
+2 IF $TEXT(GETVAR^CIAVMEVT)=""
SET @TARGET@(1,0)="Invalid context variables"
QUIT "~@"_$NAME(@TARGET)
+3 NEW VST,I,X,CNT,RESULT
+4 SET VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+5 IF VST=""
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+6 SET X="BEHOENCX"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET VST=+$$VSTR2VIS^BEHOENCX(DFN,VST)
IF VST<1
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+7 ;S X="CIAVCXEN" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^CIAVCXEN(DFN,VST) I VST<1 Q
+8 DO GETMED(.RESULT,VST)
+9 ;
+10 KILL @TARGET
SET CNT=0
+11 SET I=0
FOR
SET I=$ORDER(RESULT(I))
IF 'I
QUIT
Begin DoDot:1
+12 SET CNT=CNT+1
+13 SET @TARGET@(CNT,0)=RESULT(I)
End DoDot:1
+14 IF 'CNT
SET @TARGET@(1,0)="No Medications Found for Visit"
+15 QUIT "~@"_$NAME(@TARGET)
+16 ;
GETMED(RETURN,VIEN) ;EP returns all medications given for a visit
+1 NEW TIUX,TIUY,COUNT,TIUIS,TIULF,TIUPRV,TIURE,TIURF,RXNO,RX,TRM
+2 KILL RETURN
+3 SET COUNT=0
+4 SET TIUX=0
SET TIUY=""
FOR
SET TIUX=$ORDER(^AUPNVMED("AD",VIEN,TIUX))
IF 'TIUX
QUIT
Begin DoDot:1
+5 SET TIUY=$$GET1^DIQ(9000010.14,TIUX,.01)
+6 SET RXNO=$$GET1^DIQ(9000010.14,TIUX,1102)
+7 SET RX=""
SET RX=$ORDER(^PSRX("B",RXNO,RX))
+8 IF +RX
Begin DoDot:2
+9 ;Quit if autofinished
IF +$$GET1^DIQ(52,RX,9999999.23)
QUIT
+10 SET TIUIS=$$GET1^DIQ(52,RX,1)
+11 SET TIULF=$$GET1^DIQ(52,RX,101)
+12 SET TIUPRV=$$GET1^DIQ(52,RX,4)
+13 SET TRM=0
+14 FOR I=0:0
SET I=$ORDER(^PSRX(RX,1,I))
IF 'I
QUIT
SET TRM=TRM+1
+15 SET TIURF=$PIECE($GET(^PSRX(RX,0)),"^",9)-TRM
+16 IF COUNT>0
SET COUNT=COUNT+1
SET RETURN(COUNT)=""
+17 SET COUNT=COUNT+1
+18 SET RETURN(COUNT)=TIUY
+19 SET COUNT=COUNT+1
+20 SET RETURN(COUNT)="Issue: "_TIUIS_" Last Fill: "_TIULF
+21 SET COUNT=COUNT+1
+22 SET RETURN(COUNT)="Refills Left: "_TIURF_" Provider: "_TIUPRV
+23 IF $GET(FILLS)
DO FILLS(.RETURN,VIEN)
End DoDot:2
End DoDot:1
+24 QUIT
FILLS(RETURN,VIEN) ;Create and add nodes for fills and past fills.
+1 ;$G(^TMP("PS",$J,INDEX,0))
+2 KILL FILL
+3 NEW RFS,RF,RX2,RFL,FILL,II,PSIII,X,Y,Z,NRXN
+4 SET RX2=$SELECT($DATA(^PSRX(RX,2)):^PSRX(RX,2),1:"")
+5 SET RFL=1
+6 DO FILOOP(RX,RX2)
+7 SET Y=""
+8 FOR PSIII=0:0
SET PSIII=$ORDER(FILL(PSIII))
IF 'PSIII
QUIT
Begin DoDot:1
+9 SET X=$PIECE($GET(FILL(PSIII)),U,1)
+10 IF X=0
QUIT
+11 SET Z=$$FMTE^XLFDT(X)
+12 IF Y=""
SET Y=Z
+13 IF '$TEST
SET Y=Y_", "_Z
End DoDot:1
+14 IF Y'=""
Begin DoDot:1
+15 SET COUNT=COUNT+1
+16 SET RETURN(COUNT)="Previous fills:"
+17 SET COUNT=COUNT+1
+18 SET RETURN(COUNT)=" "_Y
End DoDot:1
+19 IF RFL<6
Begin DoDot:1
+20 KILL FILL
+21 SET Y=""
+22 SET NRXN=$PIECE($GET(^PSRX(RX,"OR1")),U,3)
+23 IF NRXN'=""
Begin DoDot:2
+24 SET RX2=$SELECT($DATA(^PSRX(NRXN,2)):^PSRX(NRXN,2),1:"")
+25 DO FILOOP(NRXN,RX2)
+26 FOR PSIII=0:0
SET PSIII=$ORDER(FILL(PSIII))
IF 'PSIII
QUIT
Begin DoDot:3
+27 SET X=$PIECE($GET(FILL(PSIII)),U,1)
+28 IF X=0
QUIT
+29 SET Z=$$FMTE^XLFDT(X)
+30 IF Y=""
SET Y=Z
+31 IF '$TEST
SET Y=Y_", "_Z
End DoDot:3
End DoDot:2
End DoDot:1
+32 IF Y'=""
Begin DoDot:1
+33 SET COUNT=COUNT+1
+34 SET RETURN(COUNT)="Past fills:"
+35 SET COUNT=COUNT+1
+36 SET RETURN(COUNT)=" "_Y
End DoDot:1
+37 QUIT
FILOOP(RX,RX2) ;
+1 SET FILL(9999999-$PIECE(RX2,"^",2))=+$PIECE(RX2,"^",2)_"^"_$SELECT($PIECE(RX2,"^",15):"(R)",1:"")
SET FILLS=+$PIECE($GET(^PSRX(RX,0)),"^",9)
+2 FOR II=0:0
SET II=$ORDER(^PSRX(RX,1,II))
IF 'II
QUIT
SET FILL(9999999-^PSRX(RX,1,II,0))=+^PSRX(RX,1,II,0)_"^"_$SELECT($PIECE(^(0),"^",16):"(R)",1:"")
SET RFL=RFL+1
+3 QUIT
+4 ;
