BHSPSO7A ; IHS/MSC/MGH - Health summary selected for medications ;27-Oct-2009 13:39;MGH
;;1.0;HEALTH SUMMARY COMONENTS;**3**;March 17,2006
;This component allows a user to use selected drugs. The routine will include any
;drugs in the VA generic finding for the drugs included
; External References
; DBIA 60 ^PSOHCSUM
; DBIA 522 ^PS(55,
; DBIA 10035 ^DPT( file #2
; DBIA 3136 ^PS(59.7,
; DBIA 10011 ^DIWP
;
MAIN ; OP Rx HS Component
N ECD,NDF,DRUG,GENERIC,GMTSEL,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP,MEDSEG
S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"")
I PSOBEGIN="" S PSOACT=1 K PSOBEGIN
K ^TMP("BHS",$J)
Q:$O(GMTSEG(GMTSEGN,50,0))'>0
S GMTSEL=0
F S GMTSEL=$O(GMTSEG(GMTSEGN,50,GMTSEL)) Q:'GMTSEL D
.S DRUG=$G(GMTSEG(GMTSEGN,50,GMTSEL))
.S MEDSEG(DRUG)=""
.S NDF=$P($G(^PSDRUG(DRUG,"ND")),U,1)
.I NDF'="" S GENERIC(NDF)=""
I '$D(^PS(55,DFN,"P")),'$D(^("ARC")) Q
I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",!
D SEL^BHSPOS(.MEDSEG) I '$D(^TMP("BHS",$J)) Q
S GMTSLO=GMTSLO+3
S (GMTOP,GMX,IX)=0
F S IX=$O(^TMP("BHS",$J,IX)) Q:IX'>0 S GMR=$G(^(IX,0)) D WRT
S GMTSLO=GMTSLO-3
K ^TMP("BHS",$J),^UTILITY($J,"W")
Q
WRT ; Writes OP Pharmacy Segment Record
N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,DIWL,DIWR,DIWF,GMSIG,GUI S GUI=$$HF^GMTSU
S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10)
; Don't display when issue date is after To Date
Q:+$G(GMRANGE)&(ID>(9999999-GMTS1))
F GMV="ID","LFD","ECD" S X=@GMV D REGDT4^GMTSU S @GMV=X K X
S NL=0,DIWL=1,DIWR=73,DIWF="" K ^UTILITY($J,"W")
F S NL=$O(^TMP("BHS",$J,IX,NL)) Q:NL'>0 D
. S X=$G(^TMP("BHS",$J,IX,NL,0)) D ^DIWP
S GMD=$P($P(GMR,U,4),";",2)
D CKP^GMTSUP Q:$D(GMTSQIT)
D:GMTSNPG!(GMX'>0) HEAD W:'GMTOP ! S GMTOP=0 W $P($P(GMR,U,3),";",2)
W !,?22,$P(GMR,U,6),?35,$P($P(GMR,U,5),";"),?39,$P(GMR,U,7),?54,ID,?65,LFD,?76,"("_$P(GMR,U,8)_")",!
S GMX=1,GMI=0,GMSIG=1
F S GMI=$O(^UTILITY($J,"W",DIWL,GMI)) Q:GMI'>0!$D(GMTSQIT) D
. D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD
. S MI=$G(^UTILITY($J,"W",DIWL,GMI,0))
. W:GMSIG=1 ?2,"SIG: " S:GMSIG=1 GMSIG=0 W ?7,MI,! S GMTOP=0
D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?4,"Provider: ",$E(GMD,1,22) W:CF ?37,"Cost/Fill: $",$J(CF,6,2)
I "EC"[$P($P(GMR,U,5),";"),ECD]"" W ?57,"Exp/Can Dt: "_ECD
W ! S GMTOP=0
Q
HEAD ; Prints Header
; Only write the next line when there is data
S GMTOP=1
I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+($P($G(^PS(59.7,1,40.1)),"^")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",!
D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Drug....................................",?65,"Last",!
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?22,"Rx #",?34,"Stat",?39,"Qty",?54,"Issued",?65,"Filled",?76,"Rem"
W:$Y'>(IOSL-GMTSLO)!(+($G(GUI))>0) !
Q
BHSPSO7A ; IHS/MSC/MGH - Health summary selected for medications ;27-Oct-2009 13:39;MGH
+1 ;;1.0;HEALTH SUMMARY COMONENTS;**3**;March 17,2006
+2 ;This component allows a user to use selected drugs. The routine will include any
+3 ;drugs in the VA generic finding for the drugs included
+4 ; External References
+5 ; DBIA 60 ^PSOHCSUM
+6 ; DBIA 522 ^PS(55,
+7 ; DBIA 10035 ^DPT( file #2
+8 ; DBIA 3136 ^PS(59.7,
+9 ; DBIA 10011 ^DIWP
+10 ;
MAIN ; OP Rx HS Component
+1 NEW ECD,NDF,DRUG,GENERIC,GMTSEL,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP,MEDSEG
+2 SET PSOBEGIN=$SELECT(GMTS2'=9999999:(9999999-GMTS2),1:"")
+3 IF PSOBEGIN=""
SET PSOACT=1
KILL PSOBEGIN
+4 KILL ^TMP("BHS",$JOB)
+5 IF $ORDER(GMTSEG(GMTSEGN,50,0))'>0
QUIT
+6 SET GMTSEL=0
+7 FOR
SET GMTSEL=$ORDER(GMTSEG(GMTSEGN,50,GMTSEL))
IF 'GMTSEL
QUIT
Begin DoDot:1
+8 SET DRUG=$GET(GMTSEG(GMTSEGN,50,GMTSEL))
+9 SET MEDSEG(DRUG)=""
+10 SET NDF=$PIECE($GET(^PSDRUG(DRUG,"ND")),U,1)
+11 IF NDF'=""
SET GENERIC(NDF)=""
End DoDot:1
+12 IF '$DATA(^PS(55,DFN,"P"))
IF '$DATA(^("ARC"))
QUIT
+13 IF '$ORDER(^PS(55,DFN,"P",0))
IF $DATA(^PS(55,DFN,"ARC"))
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE "Patient Has Archived OP Prescriptions",!
+14 DO SEL^BHSPOS(.MEDSEG)
IF '$DATA(^TMP("BHS",$JOB))
QUIT
+15 SET GMTSLO=GMTSLO+3
+16 SET (GMTOP,GMX,IX)=0
+17 FOR
SET IX=$ORDER(^TMP("BHS",$JOB,IX))
IF IX'>0
QUIT
SET GMR=$GET(^(IX,0))
DO WRT
+18 SET GMTSLO=GMTSLO-3
+19 KILL ^TMP("BHS",$JOB),^UTILITY($JOB,"W")
+20 QUIT
WRT ; Writes OP Pharmacy Segment Record
+1 NEW ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,DIWL,DIWR,DIWF,GMSIG,GUI
SET GUI=$$HF^GMTSU
+2 SET ID=$PIECE(GMR,U)
SET LFD=$PIECE(GMR,U,2)
SET ECD=$PIECE(GMR,U,11)
SET CF=$PIECE(GMR,U,10)
+3 ; Don't display when issue date is after To Date
+4 IF +$GET(GMRANGE)&(ID>(9999999-GMTS1))
QUIT
+5 FOR GMV="ID","LFD","ECD"
SET X=@GMV
DO REGDT4^GMTSU
SET @GMV=X
KILL X
+6 SET NL=0
SET DIWL=1
SET DIWR=73
SET DIWF=""
KILL ^UTILITY($JOB,"W")
+7 FOR
SET NL=$ORDER(^TMP("BHS",$JOB,IX,NL))
IF NL'>0
QUIT
Begin DoDot:1
+8 SET X=$GET(^TMP("BHS",$JOB,IX,NL,0))
DO ^DIWP
End DoDot:1
+9 SET GMD=$PIECE($PIECE(GMR,U,4),";",2)
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+11 IF GMTSNPG!(GMX'>0)
DO HEAD
IF 'GMTOP
WRITE !
SET GMTOP=0
WRITE $PIECE($PIECE(GMR,U,3),";",2)
+12 WRITE !,?22,$PIECE(GMR,U,6),?35,$PIECE($PIECE(GMR,U,5),";"),?39,$PIECE(GMR,U,7),?54,ID,?65,LFD,?76,"("_$PIECE(GMR,U,8)_")",!
+13 SET GMX=1
SET GMI=0
SET GMSIG=1
+14 FOR
SET GMI=$ORDER(^UTILITY($JOB,"W",DIWL,GMI))
IF GMI'>0!$DATA(GMTSQIT)
QUIT
Begin DoDot:1
+15 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO HEAD
+16 SET MI=$GET(^UTILITY($JOB,"W",DIWL,GMI,0))
+17 IF GMSIG=1
WRITE ?2,"SIG: "
IF GMSIG=1
SET GMSIG=0
WRITE ?7,MI,!
SET GMTOP=0
End DoDot:1
+18 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO HEAD
WRITE ?4,"Provider: ",$EXTRACT(GMD,1,22)
IF CF
WRITE ?37,"Cost/Fill: $",$JUSTIFY(CF,6,2)
+19 IF "EC"[$PIECE($PIECE(GMR,U,5),";")
IF ECD]""
WRITE ?57,"Exp/Can Dt: "_ECD
+20 WRITE !
SET GMTOP=0
+21 QUIT
HEAD ; Prints Header
+1 ; Only write the next line when there is data
+2 SET GMTOP=1
+3 IF GMX'>0
IF $DATA(^DPT(DFN,.1))
IF ^(.1)]""
IF +($PIECE($GET(^PS(59.7,1,40.1)),"^"))
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE "Outpatient prescriptions are cancelled 72 hours after admission",!
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,"Drug....................................",?65,"Last",!
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 WRITE ?22,"Rx #",?34,"Stat",?39,"Qty",?54,"Issued",?65,"Filled",?76,"Rem"
+7 IF $Y'>(IOSL-GMTSLO)!(+($GET(GUI))>0)
WRITE !
+8 QUIT
