- 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 ;