Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPORPR

RMPORPR.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; ODJ - patch 55 - re nois FGH-0800-33046 - make sure that if all
  1.  ;       12/5/00    patients option chosen dont print inactives
  1.  ;
  1.  ;RMPR*3.0*179 Flag a deceased patient by adding an '*'
  1.  ;             in front of SSN. 
  1.  ;
  1. START ; Compile and print report 
  1.  ;Set up the site.
  1.  D HOSITE^RMPOUTL0 I '$D(RMPOXITE) Q
  1.  ;
  1.  ;Intialize variables.
  1.  K DIR,DIC,DIS,DIRUT,DUOUT,DTOUT,ALL S RMPODCNT=0
  1.  ;
  1.  ; Choose one or all patients
  1.  S DIR(0)="Y",DIR("A")="Select All Patients",DIR("B")="NO" D ^DIR
  1.  Q:Y="^"!$D(DTOUT)  S ALL=Y
  1.  ; select patient
  1.  I 'ALL D SELP Q:Y<1  S (FR(1),TO(1))=Y(0,0),FR(2)=""
  1.  ; if all patients selected then print only those which are active
  1.  ; and are associated with current site.
  1.  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)=""
  1.  ; compile report        
  1.  D PRINT
  1.  D EXIT
  1.  Q
  1.  ;
  1. SELP ; Select patient
  1.  N DIR
  1.  S DIR(0)="P^665:EMZ"
  1.  S DIR("S")="I $P($G(^RMPR(665,Y,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,Y,""RMPOA"")),U,2)'="""""
  1.  D ^DIR
  1.  Q
  1.  ;
  1. PRINT ; Print report
  1.  S $P(SP," ",80)="",(^TMP("RMPO",$J,"EXTC"),COUNT,PAGE,RMEND,RMPORPT)=0
  1.  S $P(BRK,"*",80)="*"
  1.  ; get current date to print in header
  1.  D NOW^%DTC S Y=% X ^DD("DD")
  1.  S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
  1.  ; define core print driver parameters
  1.  S DIC="^RMPR(665,",BY=".01,19.4,1",L=0  ; sort by patient,Rx then vendor
  1.  S DHD="W ?0 D RPTHDR^RMPORPR"
  1.  S DIOEND="I $G(Y)'[U D END^RMPORPR S RMEND=1 S:IOST[""P-"" RMPORPT=1"
  1.  ; print sub heading
  1.  S FLDS="""Date Current"";C50"
  1.  S FLDS(1)="""Name"";C1,""SSN"";C25,""Activation Date"";C33,""Prescription Expires"";50"
  1.  S FLDS(2)="""================="";C1,""===="";C25,""==============="";C33,""====================="";C50"
  1.  ; print patient name
  1.  S FLDS(3)=".01;C1;L22;""PATIENT"""
  1.  ; print SSN
  1.  S FLDS(4)="W $$SSN^RMPORPR;C24;R5;""SSN"""
  1.  ; print Rx activation date, expiry date & prescription detail
  1.  S FLDS(5)="19.3,.01;C33,2;C50,3;S;C1"
  1.  S FLDS(6)=""""";C1;S"     ; spacer line
  1.  S FLDS(7)="19.4,1;C1;N"  ; vendor - no duplicates
  1.  ; print item detail for current prescription
  1.  S FLDS(8)="""Fund"";C68;S"
  1.  S FLDS(9)=""""";C1"
  1.  S FLDS(10)="""Extended"";C57,""Control"";C68"
  1.  S FLDS(11)="""HCPCS"";C1,""Item"";C9,""Qty"";C32,""Unit Cost"";C42,""Cost"";C57,""Point"";C68"
  1.  S FLDS(12)="""-----"";C1,""----"";C9,""---"";C32,""---------"";C42,""----"";C57,""-----"";C68"
  1.  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"
  1.  S FLDS(14)="W $$EXTC^RMPORPR;C1"
  1.  S FLDS(15)="""Inactivation Date: "";C1,19.5"
  1.  S FLDS(16)="""Inactivation Reason: "";C1,19.6"
  1.  S FLDS(17)="W BRK;C1"
  1.  S (RMPODFN,RMPOITEM)=0
  1.  D EN1^DIP
  1.  I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;
  1. ADTL() ;  Get Additional detail: cost, FCP and calculate total cost of all items
  1.  N REC,QTY,UCOST,COST,FCP
  1.  ;
  1.  I RMPODFN'=D0 S RMPODFN=D0,RMPOITEM=0
  1.  S RMPOITEM=$O(^RMPR(665,RMPODFN,"RMPOC",RMPOITEM)) Q:'+RMPOITEM ""
  1.  ;
  1.  ; quit if no items
  1.  I RMPOITEM="" S ^TMP("RMPO",$J,"ADTL")="" Q ""
  1.  ;
  1.  S REC=^RMPR(665,RMPODFN,"RMPOC",RMPOITEM,0)
  1.  S QTY=$P(REC,U,3),UCOST=$P(REC,U,4),FCP=$P($P(REC,U,6)," ")
  1.  S UCOST=UCOST*100,COST=QTY*UCOST,COST=$J(COST/100,0,2)
  1.  S ^TMP("RMPO",$J,"ADTL")=COST_U_FCP
  1.  S ^TMP("RMPO",$J,"EXTC")=$G(^TMP("RMPO",$J,"EXTC"))+COST
  1.  Q ""
  1.  ;
  1. COST() Q $P(^TMP("RMPO",$J,"ADTL"),U)
  1.  ;
  1. FCP() Q $P(^TMP("RMPO",$J,"ADTL"),U,2)
  1.  ;
  1. EXTC() ; Return extended cost
  1.  N EXTC
  1.  S EXTC=^TMP("RMPO",$J,"EXTC"),^TMP("RMPO",$J,"EXTC")=0
  1.  Q $E(SP,1,41)_"Total Cost"_$E(SP,1,5)_$J(EXTC,0,2)
  1.  ;
  1. EXIT ;
  1.  K COUNT,DTSTRG,SP,RD,RI,RNAM,BRK,X1,PAGE,RPTDT
  1.  K ROK,RY,DFN,VA,VADM,EXPDT,EXTC,RMPOITEM,RMPORX
  1.  K ^TMP("RMPO",$J) N RMPR,RMPRSITE D KILL^XUSCLEAN
  1.  Q
  1.  ;
  1. END ; End the report line
  1.  S COUNT=$E("      ",1,6-$L(COUNT))_COUNT
  1.  W !!,?47,"Total Patients: ",COUNT
  1.  S RMPODCNT=$E("      ",1,(6-$L(RMPODCNT)))_RMPODCNT   ;RMPR*3.0*179
  1.  W !,?38,"Total Deceased Patients: ",RMPODCNT   ;RMPR*3.0*179
  1.  Q
  1.  ;
  1. 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.  N X,RMPOEXP
  1.  S X="",RMPOEXP=" "
  1.  I +$G(^DPT(D0,.35)) S RMPOEXP="*"
  1.  K VA,VADM S DFN=D0 D ^VADPT
  1.  S X=$P(VA("PID"),"-",3)
  1.  I X'="" S X=RMPOEXP_X,COUNT=COUNT+1 S:RMPOEXP="*" RMPODCNT=RMPODCNT+1
  1.  Q X
  1.  ;
  1. SDT() ; Get Rx activation Date.
  1.  N X
  1.  ;
  1.  S X=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
  1.  I X S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)
  1.  Q X
  1.  ;
  1. EDT() ; Get the most recently entered Rx.
  1.  N RC,X
  1.  ;
  1.  S RMPORXDT=$O(^RMPR(665,D0,"RMPOB","B",""),-1)
  1.  ; if no prescription clear RMPORX and quit
  1.  I RMPORXDT="" S RMPORX="" Q 0
  1.  ; get Rx
  1.  S RMPORX=$O(^RMPR(665,D0,"RMPOB","B",RMPORXDT,""))
  1.  ; get Rx expire date
  1.  S RC=$P($G(^RMPR(665,D0,"RMPOB",RMPORX,0)),U,3)
  1.  Q $E(RC,4,5)_"/"_$E(RC,6,7)_"/"_($E(RC,1,3)+1700)
  1.  ;
  1. RPTHDR ; Report header      
  1.  S PAGE=PAGE+1
  1.  W RPTDT,?(40-($L(RMPO("NAME"))/2)),RMPO("NAME"),?65,"Page: "_PAGE
  1.  W !,?23,"Prescription Report",?52,"* denotes deceased patient",!
  1.  Q