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

RMPORPD.m

Go to the documentation of this file.
  1. RMPORPD ;(NG)/DG/CAP/HINES CIOFO/HNC -PRESCRIPTION EXPIRE DATE ACTIVE PATIENTS ; 5/19/00 9:12am
  1. ;;3.0;PROSTHETICS;**29,46,49,179,207**;Feb 09, 1996;Build 15
  1. ;
  1. ;RMPR*3.0*179 Check for deceased patients. Add to report by
  1. ; displaying asterisk (*) if patient deceased.
  1. ;RMPR*3.0*207 Ensure the script expiration displays correct
  1. ; dates even though script edit/add could be back dated.
  1. ;
  1. SITE ; Set up the site variables.
  1. D HOSITE^RMPOUTL0 Q:'$D(RMPOXITE)
  1. ;
  1. LI ; List the sought patient.
  1. N WHO S WHO=0,RMPODCNT=0
  1. S (RMEND,RMPORPT,PAGE,COUNT)=0
  1. D NOW^%DTC S Y=% X ^DD("DD")
  1. S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
  1. ;
  1. S DIC="^RMPR(665,"
  1. S BY(0)="^TMP(""RMPO"",$J,",L(0)=3,L=0,FR=""
  1. 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)="""""
  1. S DHIT="D CNT^RMPORPD"
  1. S DHD="W ?0 D RPTHDR^RMPORPD"
  1. S DIOEND="I $G(Y)'[U D DIOEND^RMPORPD S RMEND=1 S:IOST[""P-"" RMPORPT=1"
  1. S FLDS="W $$RXDT^RMPORPD();C1;L11"
  1. S FLDS(1)=".01;C12;L22"
  1. S FLDS(2)="W $$SSN^RMPORPD();C36;L4"
  1. S FLDS(3)="W $$PITEM^RMPORPD();C41;L30"
  1. S FLDS(4)="W $$ACTDT^RMPORPD();C73;L8"
  1. D PRESORT,EN1^DIP
  1. I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
  1. ;
  1. EXIT ;
  1. K ^TMP("RMPO",$J) N RMPRSITE,RMPR D KILL^XUSCLEAN
  1. Q
  1. ;
  1. ACTDT() ;*** ACTIVATION DATE
  1. S X=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
  1. S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
  1. Q X
  1. ;
  1. CNT ;*** COUNT NAMES
  1. I WHO'=D0 S COUNT=COUNT+1
  1. S WHO=D0
  1. Q
  1. ;
  1. ;*** CONVERT DATE FROM FILEMAN FORMAT TO MM/DD/YYYY
  1. DATE(FMD) ; RMPR*3.0*179 Flag a deceased patient by attaching an '*' to SSN. ^PT(D0,.35) direct read supported by ICR #10035
  1. N RMPOEXP S RMPOEXP=" " I +$G(^DPT(D0,.35)) S RMPOEXP="*",RMPODCNT=RMPODCNT+1
  1. Q $E(FMD,4,5)_"/"_$E(FMD,6,7)_"/"_($E(FMD,1,3)+1700)_RMPOEXP
  1. ;
  1. PITEM() ;*** GET PRIMARY ITEM AND ACTIVATION DATE
  1. N PITM,E
  1. S (E,PITM)=0,X=""
  1. F S PITM=$O(^RMPR(665,D0,"RMPOC",PITM)) Q:'PITM D Q:E
  1. . S PDT=^RMPR(665,D0,"RMPOC",PITM,0)
  1. . Q:$P(PDT,U,11)'="Y"
  1. . S X=$P(PDT,U),X=$P(^RMPR(661,X,0),U)
  1. . S X=$P($G(^PRC(441,X,0)),U,2)
  1. . S X=$E(X,1,30),E=1
  1. Q X
  1. ;
  1. PRESORT ;*** SORT BY EXPIRATION DATE
  1. N D0,D2,DFN
  1. K ^TMP("RMPO",$J)
  1. S D2=0
  1. F S D2=$O(^RMPR(665,"AHO",D2)) Q:'D2 S D0="" D
  1. . F S D0=$O(^RMPR(665,"AHO",D2,D0)) Q:D0="" D
  1. . . K VAPA,VADM S DFN=D0 D ^VADPT
  1. . . S ^TMP("RMPO",$J,$$RXDT(1),VADM(1),D0)=""
  1. Q
  1. ;
  1. RPTHDR ;*** REPORT HEADER
  1. N RA S RA=RMPO("NAME"),PAGE=PAGE+1
  1. W RPTDT,?(40-($L(RA)/2)),RA,?68,"Page: "_PAGE
  1. W !?20,"Prescription Expiration Date",!,"Date Current",?55,"'*' patient is deceased",!,"Prescription" ;RMPR*3.0*179
  1. W !?1,"Expires",?11,"Name",?35,"SSN",?41,"Primary Item",?73,"Active"
  1. W !,"==========",?11,"=======================",?35,"====",?41,"==============================",?72,"========",!
  1. Q
  1. ;
  1. ;*** EXPIRATION DATE OF CURRENT RX
  1. ; MODE Date format: 0 - MM/DD/YYYY or "N/A" (default)
  1. ; 1 - YYYMMDD or "N/A"
  1. RXDT(MODE) ;Rewrite latest expiration date determination RMPR*3.0*207
  1. N RMPRDA,RMPRDT,RMPRDAT S (RMPRDA,RMPRDT)=0
  1. F S RMPRDA=$O(^RMPR(665,D0,"RMPOB",RMPRDA)) Q:'RMPRDA D
  1. . S RMPRDAT=$P(^RMPR(665,D0,"RMPOB",RMPRDA,0),U,3) I RMPRDAT>RMPRDT S RMPRDT=RMPRDAT
  1. S X=$S('RMPRDT:"N/A",'$G(MODE):$$DATE(RMPRDT),1:RMPRDT)
  1. Q X
  1. ;
  1. SSN() ;*** SOCIAL SECURITY NUMBER
  1. K VA,VADM
  1. S DFN=D0 D ^VADPT
  1. S X=$P(VA("PID"),"-",3)
  1. Q X
  1. DIOEND ;TOTAL PRINT
  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