RMPORPR ;VA-EDS/PAK LIST HOME OXY PTS PRESCRIPTIONS/ITEMS ;7/24/98
;;3.0;PROSTHETICS;**29,55,179**;Feb 09, 1996;Build 7
;
; ODJ - patch 55 - re nois FGH-0800-33046 - make sure that if all
; 12/5/00 patients option chosen dont print inactives
;
;RMPR*3.0*179 Flag a deceased patient by adding an '*'
; in front of SSN.
;
START ; Compile and print report
;Set up the site.
D HOSITE^RMPOUTL0 I '$D(RMPOXITE) Q
;
;Intialize variables.
K DIR,DIC,DIS,DIRUT,DUOUT,DTOUT,ALL S RMPODCNT=0
;
; Choose one or all patients
S DIR(0)="Y",DIR("A")="Select All Patients",DIR("B")="NO" D ^DIR
Q:Y="^"!$D(DTOUT) S ALL=Y
; select patient
I 'ALL D SELP Q:Y<1 S (FR(1),TO(1))=Y(0,0),FR(2)=""
; if all patients selected then print only those which are active
; and are associated with current site.
I ALL S DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,D0,""RMPOA"")),U,2)'="""",$P($G(^RMPR(665,D0,""RMPOA"")),U,3)=""""",(FR,TO)=""
; compile report
D PRINT
D EXIT
Q
;
SELP ; Select patient
N DIR
S DIR(0)="P^665:EMZ"
S DIR("S")="I $P($G(^RMPR(665,Y,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,Y,""RMPOA"")),U,2)'="""""
D ^DIR
Q
;
PRINT ; Print report
S $P(SP," ",80)="",(^TMP("RMPO",$J,"EXTC"),COUNT,PAGE,RMEND,RMPORPT)=0
S $P(BRK,"*",80)="*"
; get current date to print in header
D NOW^%DTC S Y=% X ^DD("DD")
S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
; define core print driver parameters
S DIC="^RMPR(665,",BY=".01,19.4,1",L=0 ; sort by patient,Rx then vendor
S DHD="W ?0 D RPTHDR^RMPORPR"
S DIOEND="I $G(Y)'[U D END^RMPORPR S RMEND=1 S:IOST[""P-"" RMPORPT=1"
; print sub heading
S FLDS="""Date Current"";C50"
S FLDS(1)="""Name"";C1,""SSN"";C25,""Activation Date"";C33,""Prescription Expires"";50"
S FLDS(2)="""================="";C1,""===="";C25,""==============="";C33,""====================="";C50"
; print patient name
S FLDS(3)=".01;C1;L22;""PATIENT"""
; print SSN
S FLDS(4)="W $$SSN^RMPORPR;C24;R5;""SSN"""
; print Rx activation date, expiry date & prescription detail
S FLDS(5)="19.3,.01;C33,2;C50,3;S;C1"
S FLDS(6)=""""";C1;S" ; spacer line
S FLDS(7)="19.4,1;C1;N" ; vendor - no duplicates
; print item detail for current prescription
S FLDS(8)="""Fund"";C68;S"
S FLDS(9)=""""";C1"
S FLDS(10)="""Extended"";C57,""Control"";C68"
S FLDS(11)="""HCPCS"";C1,""Item"";C9,""Qty"";C32,""Unit Cost"";C42,""Cost"";C57,""Point"";C68"
S FLDS(12)="""-----"";C1,""----"";C9,""---"";C32,""---------"";C42,""----"";C57,""-----"";C68"
S FLDS(13)="19.4,W $$ADTL^RMPORPR;C1,6;C1;L8,.01;C9;L21,2;C32;L4,3;C42;L8,W $$COST^RMPORPR;C57,W $$FCP^RMPORPR;C68"
S FLDS(14)="W $$EXTC^RMPORPR;C1"
S FLDS(15)="""Inactivation Date: "";C1,19.5"
S FLDS(16)="""Inactivation Reason: "";C1,19.6"
S FLDS(17)="W BRK;C1"
S (RMPODFN,RMPOITEM)=0
D EN1^DIP
I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
Q
;
ADTL() ; Get Additional detail: cost, FCP and calculate total cost of all items
N REC,QTY,UCOST,COST,FCP
;
I RMPODFN'=D0 S RMPODFN=D0,RMPOITEM=0
S RMPOITEM=$O(^RMPR(665,RMPODFN,"RMPOC",RMPOITEM)) Q:'+RMPOITEM ""
;
; quit if no items
I RMPOITEM="" S ^TMP("RMPO",$J,"ADTL")="" Q ""
;
S REC=^RMPR(665,RMPODFN,"RMPOC",RMPOITEM,0)
S QTY=$P(REC,U,3),UCOST=$P(REC,U,4),FCP=$P($P(REC,U,6)," ")
S UCOST=UCOST*100,COST=QTY*UCOST,COST=$J(COST/100,0,2)
S ^TMP("RMPO",$J,"ADTL")=COST_U_FCP
S ^TMP("RMPO",$J,"EXTC")=$G(^TMP("RMPO",$J,"EXTC"))+COST
Q ""
;
COST() Q $P(^TMP("RMPO",$J,"ADTL"),U)
;
FCP() Q $P(^TMP("RMPO",$J,"ADTL"),U,2)
;
EXTC() ; Return extended cost
N EXTC
S EXTC=^TMP("RMPO",$J,"EXTC"),^TMP("RMPO",$J,"EXTC")=0
Q $E(SP,1,41)_"Total Cost"_$E(SP,1,5)_$J(EXTC,0,2)
;
EXIT ;
K COUNT,DTSTRG,SP,RD,RI,RNAM,BRK,X1,PAGE,RPTDT
K ROK,RY,DFN,VA,VADM,EXPDT,EXTC,RMPOITEM,RMPORX
K ^TMP("RMPO",$J) N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
;
END ; End the report line
S COUNT=$E(" ",1,6-$L(COUNT))_COUNT
W !!,?47,"Total Patients: ",COUNT
S RMPODCNT=$E(" ",1,(6-$L(RMPODCNT)))_RMPODCNT ;RMPR*3.0*179
W !,?38,"Total Deceased Patients: ",RMPODCNT ;RMPR*3.0*179
Q
;
SSN() ; Get SSN ;RNPR*3.0*179 Flag a deceased patient by attaching an '*' to SSN. ^DPT(D0,.35) direct read supported by ICR #10035
N X,RMPOEXP
S X="",RMPOEXP=" "
I +$G(^DPT(D0,.35)) S RMPOEXP="*"
K VA,VADM S DFN=D0 D ^VADPT
S X=$P(VA("PID"),"-",3)
I X'="" S X=RMPOEXP_X,COUNT=COUNT+1 S:RMPOEXP="*" RMPODCNT=RMPODCNT+1
Q X
;
SDT() ; Get Rx activation Date.
N X
;
S X=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
I X S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)
Q X
;
EDT() ; Get the most recently entered Rx.
N RC,X
;
S RMPORXDT=$O(^RMPR(665,D0,"RMPOB","B",""),-1)
; if no prescription clear RMPORX and quit
I RMPORXDT="" S RMPORX="" Q 0
; get Rx
S RMPORX=$O(^RMPR(665,D0,"RMPOB","B",RMPORXDT,""))
; get Rx expire date
S RC=$P($G(^RMPR(665,D0,"RMPOB",RMPORX,0)),U,3)
Q $E(RC,4,5)_"/"_$E(RC,6,7)_"/"_($E(RC,1,3)+1700)
;
RPTHDR ; Report header
S PAGE=PAGE+1
W RPTDT,?(40-($L(RMPO("NAME"))/2)),RMPO("NAME"),?65,"Page: "_PAGE
W !,?23,"Prescription Report",?52,"* denotes deceased patient",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPORPR 5246 printed Apr 09, 2024@21:39:22 Page 2
RMPORPR ;VA-EDS/PAK LIST HOME OXY PTS PRESCRIPTIONS/ITEMS ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,55,179**;Feb 09, 1996;Build 7
+2 ;
+3 ; ODJ - patch 55 - re nois FGH-0800-33046 - make sure that if all
+4 ; 12/5/00 patients option chosen dont print inactives
+5 ;
+6 ;RMPR*3.0*179 Flag a deceased patient by adding an '*'
+7 ; in front of SSN.
+8 ;
START ; Compile and print report
+1 ;Set up the site.
+2 DO HOSITE^RMPOUTL0
IF '$DATA(RMPOXITE)
QUIT
+3 ;
+4 ;Intialize variables.
+5 KILL DIR,DIC,DIS,DIRUT,DUOUT,DTOUT,ALL
SET RMPODCNT=0
+6 ;
+7 ; Choose one or all patients
+8 SET DIR(0)="Y"
SET DIR("A")="Select All Patients"
SET DIR("B")="NO"
DO ^DIR
+9 if Y="^"!$DATA(DTOUT)
QUIT
SET ALL=Y
+10 ; select patient
+11 IF 'ALL
DO SELP
if Y<1
QUIT
SET (FR(1),TO(1))=Y(0,0)
SET FR(2)=""
+12 ; if all patients selected then print only those which are active
+13 ; and are associated with current site.
+14 IF ALL
SET DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,D0,""RMPOA"")),U,2)'="""",$P($G(^RMPR(665,D0,""RMPOA"")),U,3)="""""
SET (FR,TO)=""
+15 ; compile report
+16 DO PRINT
+17 DO EXIT
+18 QUIT
+19 ;
SELP ; Select patient
+1 NEW DIR
+2 SET DIR(0)="P^665:EMZ"
+3 SET DIR("S")="I $P($G(^RMPR(665,Y,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,Y,""RMPOA"")),U,2)'="""""
+4 DO ^DIR
+5 QUIT
+6 ;
PRINT ; Print report
+1 SET $PIECE(SP," ",80)=""
SET (^TMP("RMPO",$JOB,"EXTC"),COUNT,PAGE,RMEND,RMPORPT)=0
+2 SET $PIECE(BRK,"*",80)="*"
+3 ; get current date to print in header
+4 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+5 SET RPTDT=$PIECE(Y,"@",1)_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+6 ; define core print driver parameters
+7 ; sort by patient,Rx then vendor
SET DIC="^RMPR(665,"
SET BY=".01,19.4,1"
SET L=0
+8 SET DHD="W ?0 D RPTHDR^RMPORPR"
+9 SET DIOEND="I $G(Y)'[U D END^RMPORPR S RMEND=1 S:IOST[""P-"" RMPORPT=1"
+10 ; print sub heading
+11 SET FLDS="""Date Current"";C50"
+12 SET FLDS(1)="""Name"";C1,""SSN"";C25,""Activation Date"";C33,""Prescription Expires"";50"
+13 SET FLDS(2)="""================="";C1,""===="";C25,""==============="";C33,""====================="";C50"
+14 ; print patient name
+15 SET FLDS(3)=".01;C1;L22;""PATIENT"""
+16 ; print SSN
+17 SET FLDS(4)="W $$SSN^RMPORPR;C24;R5;""SSN"""
+18 ; print Rx activation date, expiry date & prescription detail
+19 SET FLDS(5)="19.3,.01;C33,2;C50,3;S;C1"
+20 ; spacer line
SET FLDS(6)=""""";C1;S"
+21 ; vendor - no duplicates
SET FLDS(7)="19.4,1;C1;N"
+22 ; print item detail for current prescription
+23 SET FLDS(8)="""Fund"";C68;S"
+24 SET FLDS(9)=""""";C1"
+25 SET FLDS(10)="""Extended"";C57,""Control"";C68"
+26 SET FLDS(11)="""HCPCS"";C1,""Item"";C9,""Qty"";C32,""Unit Cost"";C42,""Cost"";C57,""Point"";C68"
+27 SET FLDS(12)="""-----"";C1,""----"";C9,""---"";C32,""---------"";C42,""----"";C57,""-----"";C68"
+28 SET FLDS(13)="19.4,W $$ADTL^RMPORPR;C1,6;C1;L8,.01;C9;L21,2;C32;L4,3;C42;L8,W $$COST^RMPORPR;C57,W $$FCP^RMPORPR;C68"
+29 SET FLDS(14)="W $$EXTC^RMPORPR;C1"
+30 SET FLDS(15)="""Inactivation Date: "";C1,19.5"
+31 SET FLDS(16)="""Inactivation Reason: "";C1,19.6"
+32 SET FLDS(17)="W BRK;C1"
+33 SET (RMPODFN,RMPOITEM)=0
+34 DO EN1^DIP
+35 IF RMPORPT=0
IF $GET(RMEND)
KILL DIR
SET DIR(0)="E"
DO ^DIR
+36 QUIT
+37 ;
ADTL() ; Get Additional detail: cost, FCP and calculate total cost of all items
+1 NEW REC,QTY,UCOST,COST,FCP
+2 ;
+3 IF RMPODFN'=D0
SET RMPODFN=D0
SET RMPOITEM=0
+4 SET RMPOITEM=$ORDER(^RMPR(665,RMPODFN,"RMPOC",RMPOITEM))
if '+RMPOITEM
QUIT ""
+5 ;
+6 ; quit if no items
+7 IF RMPOITEM=""
SET ^TMP("RMPO",$JOB,"ADTL")=""
QUIT ""
+8 ;
+9 SET REC=^RMPR(665,RMPODFN,"RMPOC",RMPOITEM,0)
+10 SET QTY=$PIECE(REC,U,3)
SET UCOST=$PIECE(REC,U,4)
SET FCP=$PIECE($PIECE(REC,U,6)," ")
+11 SET UCOST=UCOST*100
SET COST=QTY*UCOST
SET COST=$JUSTIFY(COST/100,0,2)
+12 SET ^TMP("RMPO",$JOB,"ADTL")=COST_U_FCP
+13 SET ^TMP("RMPO",$JOB,"EXTC")=$GET(^TMP("RMPO",$JOB,"EXTC"))+COST
+14 QUIT ""
+15 ;
COST() QUIT $PIECE(^TMP("RMPO",$JOB,"ADTL"),U)
+1 ;
FCP() QUIT $PIECE(^TMP("RMPO",$JOB,"ADTL"),U,2)
+1 ;
EXTC() ; Return extended cost
+1 NEW EXTC
+2 SET EXTC=^TMP("RMPO",$JOB,"EXTC")
SET ^TMP("RMPO",$JOB,"EXTC")=0
+3 QUIT $EXTRACT(SP,1,41)_"Total Cost"_$EXTRACT(SP,1,5)_$JUSTIFY(EXTC,0,2)
+4 ;
EXIT ;
+1 KILL COUNT,DTSTRG,SP,RD,RI,RNAM,BRK,X1,PAGE,RPTDT
+2 KILL ROK,RY,DFN,VA,VADM,EXPDT,EXTC,RMPOITEM,RMPORX
+3 KILL ^TMP("RMPO",$JOB)
NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+4 QUIT
+5 ;
END ; End the report line
+1 SET COUNT=$EXTRACT(" ",1,6-$LENGTH(COUNT))_COUNT
+2 WRITE !!,?47,"Total Patients: ",COUNT
+3 ;RMPR*3.0*179
SET RMPODCNT=$EXTRACT(" ",1,(6-$LENGTH(RMPODCNT)))_RMPODCNT
+4 ;RMPR*3.0*179
WRITE !,?38,"Total Deceased Patients: ",RMPODCNT
+5 QUIT
+6 ;
SSN() ; Get SSN ;RNPR*3.0*179 Flag a deceased patient by attaching an '*' to SSN. ^DPT(D0,.35) direct read supported by ICR #10035
+1 NEW X,RMPOEXP
+2 SET X=""
SET RMPOEXP=" "
+3 IF +$GET(^DPT(D0,.35))
SET RMPOEXP="*"
+4 KILL VA,VADM
SET DFN=D0
DO ^VADPT
+5 SET X=$PIECE(VA("PID"),"-",3)
+6 IF X'=""
SET X=RMPOEXP_X
SET COUNT=COUNT+1
if RMPOEXP="*"
SET RMPODCNT=RMPODCNT+1
+7 QUIT X
+8 ;
SDT() ; Get Rx activation Date.
+1 NEW X
+2 ;
+3 SET X=$PIECE($GET(^RMPR(665,D0,"RMPOA")),U,2)
+4 IF X
SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_($EXTRACT(X,1,3)+1700)
+5 QUIT X
+6 ;
EDT() ; Get the most recently entered Rx.
+1 NEW RC,X
+2 ;
+3 SET RMPORXDT=$ORDER(^RMPR(665,D0,"RMPOB","B",""),-1)
+4 ; if no prescription clear RMPORX and quit
+5 IF RMPORXDT=""
SET RMPORX=""
QUIT 0
+6 ; get Rx
+7 SET RMPORX=$ORDER(^RMPR(665,D0,"RMPOB","B",RMPORXDT,""))
+8 ; get Rx expire date
+9 SET RC=$PIECE($GET(^RMPR(665,D0,"RMPOB",RMPORX,0)),U,3)
+10 QUIT $EXTRACT(RC,4,5)_"/"_$EXTRACT(RC,6,7)_"/"_($EXTRACT(RC,1,3)+1700)
+11 ;
RPTHDR ; Report header
+1 SET PAGE=PAGE+1
+2 WRITE RPTDT,?(40-($LENGTH(RMPO("NAME"))/2)),RMPO("NAME"),?65,"Page: "_PAGE
+3 WRITE !,?23,"Prescription Report",?52,"* denotes deceased patient",!
+4 QUIT
