APSQSHOW ;IHS/ASDS/ENM/POC/CIA/PLS - SHOW RX THAT ARE OUTSIDE (ONLY IN V MED FILE AS EVENTS) ;26-Feb-2013 11:11;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1016**;Sep 23, 2004;Build 74
; Modified IHS/MSC/MGH - 02/26/13 - Patch 1016 to exclude eRX meds from appearing
; twice and to exclude DC'd meds
;S EN ="SHOW" TO SHOW ENTRIES
;S EN ="INVEN" TO PROCESS INTERVENTIONS
EN(EN,NVFLG) ;EP - IHS/MSC/PLS - 11/16/07 - New EP
; Modified - IHS/CIA/PLS - 01/14/04 - Added FMTLINE API
Q:'$D(EN)
S NVFLG=$G(NVFLG,0)
K ARR
S PSODFN=$G(PSODFN,$G(DFN,0)) ; IHS/CIA/PLS - 01/25/04
Q:'PSODFN
S X1=DT,X2=-365 D C^%DTC S ARREDATE=X
;S ERR=$$MEDS^APSPORXF(PSODFN,"ARR(",ARREDATE,DT,"E")
;Q:ERR
D FAST
D ALL
I EN="SHOW" I $Y+5>IOSL K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT) PSOQFLG=1 K DIRUT,DTOUT,DUOUT,DIROUT
D:EN="SHOW" CLEAN1
;WE'LL CLEAN UP FROM PSODSPL
K EN
Q
ALL S ARRNUM=0 F Q:$G(ARRNUM)="" S ARRNUM=$O(ARR(ARRNUM)) Q:(ARRNUM="")!($G(PSOQFLG)=1) D
.S ARRNODE=ARR(ARRNUM)
.S ARRDYS=$P(ARRNODE,U,9)
.S ARRISS=$P(ARRNODE,U,3)
.S X1=ARRISS,X2=$S(ARRDYS*2>60:ARRDYS*2,1:60) ;AT LEAST 60 DAYS OR TIMES 2 OF DYS SUPPLY
.D C^%DTC Q:DT>X
.S ARRDRIEN=$P(ARRNODE,U,4)
.S ARRQTY=$P(ARRNODE,U,8)
.S ARRDRUG=$S($P(ARRNODE,U,6)]"":"%"_$P(ARRNODE,U,6),1:$P(ARRNODE,U,5))
.S ARRDRUG=$E(ARRDRUG,1,20)_" ["_$E($P(ARRNODE,U,11),1,10)_"]"
.S ARRNDF=$S($G(^PSDRUG(ARRDRIEN,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
.S ARRCLASS=$P(^PSDRUG(ARRDRIEN,0),U,2)
.D @EN
.Q
Q
SHOW W !
W ?1,"OUTSIDE RX"
W ?13," ",$E(ARRDRUG,1,30),?49,$J(ARRQTY,3)
W ?53,$E(ARRISS,4,5),"-",$E(ARRISS,6,7),?74,$J(ARRDYS,3)
;I $Y+2>IOSL K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT) PSOQFLG=1 K DIRUT,DTOUT,DUOUT,DIROUT
Q
;
INVEN ;
S AZOSD(ARRDRUG)="^99^^^"_ARRCLASS_"^^"_ARRNDF_"^"_ARRDYS
Q
CLEAN1 K EN
CLEAN D EN^XBVK("ARR")
Q
FAST ;FASTER LOOKUP HARDCODED
;K ARRNUM
;REMEMBER THE DATES ARE IN REVERSE ORDER
S ARRDATST=9999999-ARREDATE,ARRDA=0,ARRREVDT="" ;ARRDATST=END DATE
F S ARRREVDT=$O(^AUPNVMED("AA",PSODFN,ARRREVDT)) Q:ARRREVDT=""!(ARRREVDT=ARRDATST) F S ARRDA=$O(^AUPNVMED("AA",PSODFN,ARRREVDT,ARRDA)) Q:ARRDA="" D
.S ARRSTR=$G(^AUPNVMED(ARRDA,0))
.I $G(NVFLG) Q:$P($G(^AUPNVMED(ARRDA,11)),U,8) ; Prevent Non-VA Meds from appearing twice.
.Q:'ARRSTR
.S ARRVISIT=$P(ARRSTR,"^",3)
.Q:'ARRVISIT
.Q:$P($G(^AUPNVMED(ARRDA,0)),U,8) ;IHS/MSC/MGH P1016 Don't output discontinued meds
.Q:$P($G(^AUPNVSIT(ARRVISIT,0)),"^",7)'="E" ;GOT TO BE EVENT
.S ARRDAY=+$G(^AUPNVSIT(ARRVISIT,0)),ARRDAY=$P(ARRDAY,".",1) ;DATE
.Q:'ARRDAY
.;IHS/MSC/MGH P1016 don't output eRX meds
.S ARRERX=$P($G(^AUPNVMED(ARRDA,11)),U,2)
.Q:$E(ARRERX,1,1)="X"
.;THESE LINES UNCOMMENTED IF WANT TO LIMIT DRUGS SHOWING BY DAYS SUPPLY
.S ARRDAY1=$P(ARRSTR,"^",7) ;DAYS SUPPLY
.I ARRDAY1 S ARRDAY1=2*ARRDAY1,X1=ARRDAY,X2=ARRDAY1 D C^%DTC Q:DT>X
.;END OF SUBROUTINE THAT LIMITS SHOWING DRUGS TO 2 X DAYS SUPPLY IHS/OKCAO/POC 6/25/98
.;S ARRDIEN=$P(ARRSTR,"^",3)
.S ARRDIEN=+ARRSTR
.Q:'ARRDIEN
.S ARRDRUG=$P($G(^PSDRUG(ARRDIEN,0)),"^",1)
.Q:ARRDRUG=""
.I $P(ARRSTR,"^",4)]"" S ARRDRUG="%"_$P(ARRSTR,"^",4) ;IF NON TABLE DRUG
.S ARROUTLC=$P($G(^AUPNVSIT(ARRVISIT,21)),"^",1)
.S ARRNUM=$G(ARRNUM)+1
.S ARR(ARRNUM)=ARRDA_"^"_ARRVISIT_"^"_ARRDAY_"^"_ARRDIEN_"^"_ARRDRUG_"^^"_$P(ARRSTR,"^",5)_"^"_$P(ARRSTR,"^",6)_"^"_$P(ARRSTR,"^",7)_"^^"_ARROUTLC
.Q
Q
; Returns formatted list of outside Rxs in data
FMTLINES(DATA,CNT,NVFLG) ; EP IHS/CIA/PLS - 01/15/04
N ARR,ARRDA,ARRDATST,ARRDAY,ARRDAY1,ARRDIEN,ARRDRUG,ARREDATE
N ARRNUM,ARROUTLC,ARRREVDT,ARRNODE,ARRDYS,ARRISS,X1,X2,ARRQTY
N ARRSTR,ARRVISIT,ARRNDF,ARRCLASS,ARRDRIEN,NODE
S NVFLG=$G(NVFLG,0)
S PSODFN=$G(PSODFN,$G(DFN,0)) ; IHS/CIA/PLS - 01/25/04
Q:'PSODFN
S ARREDATE=$$FMADD^XLFDT(DT,-365)
D FAST
S ARRNUM=0 F Q:$G(ARRNUM)="" S ARRNUM=$O(ARR(ARRNUM)) Q:'ARRNUM D
.S ARRNODE=ARR(ARRNUM)
.S ARRDYS=$P(ARRNODE,U,9)
.S ARRISS=$P(ARRNODE,U,3)
.Q:DT>$$FMADD^XLFDT(ARRISS,$S(ARRDYS*2>60:ARRDYS*2,1:60)) ; At least 60 days or 2x days supply
.S ARRDRIEN=$P(ARRNODE,U,4)
.S ARRQTY=$P(ARRNODE,U,8)
.S ARRDRUG=$S($P(ARRNODE,U,6)]"":"%"_$P(ARRNODE,U,6),1:$P(ARRNODE,U,5))
.S ARRDRUG=$E(ARRDRUG,1,20)_" ["_$E($P(ARRNODE,U,11),1,10)_"]"
.S ARRNDF=$S($G(^PSDRUG(ARRDRIEN,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
.S ARRCLASS=$P(^PSDRUG(ARRDRIEN,0),U,2)
.S CNT=CNT+1
.S NODE="OUTSIDE RX "_$E(ARRDRUG,1,30)_" "_$J(ARRQTY,3)_" "_$E(ARRISS,4,5)
.S NODE=NODE_"-"_$E(ARRISS,6,7)_" "_$J(ARRDYS,4)
.S @DATA@(CNT,0)=NODE
Q
APSQSHOW ;IHS/ASDS/ENM/POC/CIA/PLS - SHOW RX THAT ARE OUTSIDE (ONLY IN V MED FILE AS EVENTS) ;26-Feb-2013 11:11;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1016**;Sep 23, 2004;Build 74
+2 ; Modified IHS/MSC/MGH - 02/26/13 - Patch 1016 to exclude eRX meds from appearing
+3 ; twice and to exclude DC'd meds
+4 ;S EN ="SHOW" TO SHOW ENTRIES
+5 ;S EN ="INVEN" TO PROCESS INTERVENTIONS
EN(EN,NVFLG) ;EP - IHS/MSC/PLS - 11/16/07 - New EP
+1 ; Modified - IHS/CIA/PLS - 01/14/04 - Added FMTLINE API
+2 IF '$DATA(EN)
QUIT
+3 SET NVFLG=$GET(NVFLG,0)
+4 KILL ARR
+5 ; IHS/CIA/PLS - 01/25/04
SET PSODFN=$GET(PSODFN,$GET(DFN,0))
+6 IF 'PSODFN
QUIT
+7 SET X1=DT
SET X2=-365
DO C^%DTC
SET ARREDATE=X
+8 ;S ERR=$$MEDS^APSPORXF(PSODFN,"ARR(",ARREDATE,DT,"E")
+9 ;Q:ERR
+10 DO FAST
+11 DO ALL
+12 IF EN="SHOW"
IF $Y+5>IOSL
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET PSOQFLG=1
KILL DIRUT,DTOUT,DUOUT,DIROUT
+13 IF EN="SHOW"
DO CLEAN1
+14 ;WE'LL CLEAN UP FROM PSODSPL
+15 KILL EN
+16 QUIT
ALL SET ARRNUM=0
FOR
IF $GET(ARRNUM)=""
QUIT
SET ARRNUM=$ORDER(ARR(ARRNUM))
IF (ARRNUM="")!($GET(PSOQFLG)=1)
QUIT
Begin DoDot:1
+1 SET ARRNODE=ARR(ARRNUM)
+2 SET ARRDYS=$PIECE(ARRNODE,U,9)
+3 SET ARRISS=$PIECE(ARRNODE,U,3)
+4 ;AT LEAST 60 DAYS OR TIMES 2 OF DYS SUPPLY
SET X1=ARRISS
SET X2=$SELECT(ARRDYS*2>60:ARRDYS*2,1:60)
+5 DO C^%DTC
IF DT>X
QUIT
+6 SET ARRDRIEN=$PIECE(ARRNODE,U,4)
+7 SET ARRQTY=$PIECE(ARRNODE,U,8)
+8 SET ARRDRUG=$SELECT($PIECE(ARRNODE,U,6)]"":"%"_$PIECE(ARRNODE,U,6),1:$PIECE(ARRNODE,U,5))
+9 SET ARRDRUG=$EXTRACT(ARRDRUG,1,20)_" ["_$EXTRACT($PIECE(ARRNODE,U,11),1,10)_"]"
+10 SET ARRNDF=$SELECT($GET(^PSDRUG(ARRDRIEN,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+11 SET ARRCLASS=$PIECE(^PSDRUG(ARRDRIEN,0),U,2)
+12 DO @EN
+13 QUIT
End DoDot:1
+14 QUIT
SHOW WRITE !
+1 WRITE ?1,"OUTSIDE RX"
+2 WRITE ?13," ",$EXTRACT(ARRDRUG,1,30),?49,$JUSTIFY(ARRQTY,3)
+3 WRITE ?53,$EXTRACT(ARRISS,4,5),"-",$EXTRACT(ARRISS,6,7),?74,$JUSTIFY(ARRDYS,3)
+4 ;I $Y+2>IOSL K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT) PSOQFLG=1 K DIRUT,DTOUT,DUOUT,DIROUT
+5 QUIT
+6 ;
INVEN ;
+1 SET AZOSD(ARRDRUG)="^99^^^"_ARRCLASS_"^^"_ARRNDF_"^"_ARRDYS
+2 QUIT
CLEAN1 KILL EN
CLEAN DO EN^XBVK("ARR")
+1 QUIT
FAST ;FASTER LOOKUP HARDCODED
+1 ;K ARRNUM
+2 ;REMEMBER THE DATES ARE IN REVERSE ORDER
+3 ;ARRDATST=END DATE
SET ARRDATST=9999999-ARREDATE
SET ARRDA=0
SET ARRREVDT=""
+4 FOR
SET ARRREVDT=$ORDER(^AUPNVMED("AA",PSODFN,ARRREVDT))
IF ARRREVDT=""!(ARRREVDT=ARRDATST)
QUIT
FOR
SET ARRDA=$ORDER(^AUPNVMED("AA",PSODFN,ARRREVDT,ARRDA))
IF ARRDA=""
QUIT
Begin DoDot:1
+5 SET ARRSTR=$GET(^AUPNVMED(ARRDA,0))
+6 ; Prevent Non-VA Meds from appearing twice.
IF $GET(NVFLG)
IF $PIECE($GET(^AUPNVMED(ARRDA,11)),U,8)
QUIT
+7 IF 'ARRSTR
QUIT
+8 SET ARRVISIT=$PIECE(ARRSTR,"^",3)
+9 IF 'ARRVISIT
QUIT
+10 ;IHS/MSC/MGH P1016 Don't output discontinued meds
IF $PIECE($GET(^AUPNVMED(ARRDA,0)),U,8)
QUIT
+11 ;GOT TO BE EVENT
IF $PIECE($GET(^AUPNVSIT(ARRVISIT,0)),"^",7)'="E"
QUIT
+12 ;DATE
SET ARRDAY=+$GET(^AUPNVSIT(ARRVISIT,0))
SET ARRDAY=$PIECE(ARRDAY,".",1)
+13 IF 'ARRDAY
QUIT
+14 ;IHS/MSC/MGH P1016 don't output eRX meds
+15 SET ARRERX=$PIECE($GET(^AUPNVMED(ARRDA,11)),U,2)
+16 IF $EXTRACT(ARRERX,1,1)="X"
QUIT
+17 ;THESE LINES UNCOMMENTED IF WANT TO LIMIT DRUGS SHOWING BY DAYS SUPPLY
+18 ;DAYS SUPPLY
SET ARRDAY1=$PIECE(ARRSTR,"^",7)
+19 IF ARRDAY1
SET ARRDAY1=2*ARRDAY1
SET X1=ARRDAY
SET X2=ARRDAY1
DO C^%DTC
IF DT>X
QUIT
+20 ;END OF SUBROUTINE THAT LIMITS SHOWING DRUGS TO 2 X DAYS SUPPLY IHS/OKCAO/POC 6/25/98
+21 ;S ARRDIEN=$P(ARRSTR,"^",3)
+22 SET ARRDIEN=+ARRSTR
+23 IF 'ARRDIEN
QUIT
+24 SET ARRDRUG=$PIECE($GET(^PSDRUG(ARRDIEN,0)),"^",1)
+25 IF ARRDRUG=""
QUIT
+26 ;IF NON TABLE DRUG
IF $PIECE(ARRSTR,"^",4)]""
SET ARRDRUG="%"_$PIECE(ARRSTR,"^",4)
+27 SET ARROUTLC=$PIECE($GET(^AUPNVSIT(ARRVISIT,21)),"^",1)
+28 SET ARRNUM=$GET(ARRNUM)+1
+29 SET ARR(ARRNUM)=ARRDA_"^"_ARRVISIT_"^"_ARRDAY_"^"_ARRDIEN_"^"_ARRDRUG_"^^"_$PIECE(ARRSTR,"^",5)_"^"_$PIECE(ARRSTR,"^",6)_"^"_$PIECE(ARRSTR,"^",7)_"^^"_ARROUTLC
+30 QUIT
End DoDot:1
+31 QUIT
+32 ; Returns formatted list of outside Rxs in data
FMTLINES(DATA,CNT,NVFLG) ; EP IHS/CIA/PLS - 01/15/04
+1 NEW ARR,ARRDA,ARRDATST,ARRDAY,ARRDAY1,ARRDIEN,ARRDRUG,ARREDATE
+2 NEW ARRNUM,ARROUTLC,ARRREVDT,ARRNODE,ARRDYS,ARRISS,X1,X2,ARRQTY
+3 NEW ARRSTR,ARRVISIT,ARRNDF,ARRCLASS,ARRDRIEN,NODE
+4 SET NVFLG=$GET(NVFLG,0)
+5 ; IHS/CIA/PLS - 01/25/04
SET PSODFN=$GET(PSODFN,$GET(DFN,0))
+6 IF 'PSODFN
QUIT
+7 SET ARREDATE=$$FMADD^XLFDT(DT,-365)
+8 DO FAST
+9 SET ARRNUM=0
FOR
IF $GET(ARRNUM)=""
QUIT
SET ARRNUM=$ORDER(ARR(ARRNUM))
IF 'ARRNUM
QUIT
Begin DoDot:1
+10 SET ARRNODE=ARR(ARRNUM)
+11 SET ARRDYS=$PIECE(ARRNODE,U,9)
+12 SET ARRISS=$PIECE(ARRNODE,U,3)
+13 ; At least 60 days or 2x days supply
IF DT>$$FMADD^XLFDT(ARRISS,$SELECT(ARRDYS*2>60
QUIT
+14 SET ARRDRIEN=$PIECE(ARRNODE,U,4)
+15 SET ARRQTY=$PIECE(ARRNODE,U,8)
+16 SET ARRDRUG=$SELECT($PIECE(ARRNODE,U,6)]"":"%"_$PIECE(ARRNODE,U,6),1:$PIECE(ARRNODE,U,5))
+17 SET ARRDRUG=$EXTRACT(ARRDRUG,1,20)_" ["_$EXTRACT($PIECE(ARRNODE,U,11),1,10)_"]"
+18 SET ARRNDF=$SELECT($GET(^PSDRUG(ARRDRIEN,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+19 SET ARRCLASS=$PIECE(^PSDRUG(ARRDRIEN,0),U,2)
+20 SET CNT=CNT+1
+21 SET NODE="OUTSIDE RX "_$EXTRACT(ARRDRUG,1,30)_" "_$JUSTIFY(ARRQTY,3)_" "_$EXTRACT(ARRISS,4,5)
+22 SET NODE=NODE_"-"_$EXTRACT(ARRISS,6,7)_" "_$JUSTIFY(ARRDYS,4)
+23 SET @DATA@(CNT,0)=NODE
End DoDot:1
+24 QUIT
