source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPORPD.m@ 1476

Last change on this file since 1476 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1RMPORPD ;(NG)/DG/CAP/HINES CIOFO/HNC -PRESCRIPTION EXPIRE DATE ACTIVE PATIENTS ; 5/19/00 9:12am
2 ;;3.0;PROSTHETICS;**29,46,49**;Feb 09, 1996
3 ;
4SITE ; Set up the site variables.
5 D HOSITE^RMPOUTL0 Q:'$D(RMPOXITE)
6 ;
7LI ; List the sought patient.
8 N WHO S WHO=0
9 S (RMEND,RMPORPT,PAGE,COUNT)=0
10 D NOW^%DTC S Y=% X ^DD("DD")
11 S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
12 ;
13 S DIC="^RMPR(665,"
14 S BY(0)="^TMP(""RMPO"",$J,",L(0)=3,L=0,FR=""
15 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)="""""
16 S DHIT="D CNT^RMPORPD"
17 S DHD="W ?0 D RPTHDR^RMPORPD"
18 S DIOEND="I $G(Y)'[U W !!,?50,""Total Patients: "",$J(COUNT,6) S RMEND=1 S:IOST[""P-"" RMPORPT=1"
19 S FLDS="W $$RXDT^RMPORPD();C1;L10"
20 S FLDS(1)=".01;C12;L22"
21 S FLDS(2)="W $$SSN^RMPORPD();C36;L4"
22 S FLDS(3)="W $$PITEM^RMPORPD();C41;L30"
23 S FLDS(4)="W $$ACTDT^RMPORPD();C73;L8"
24 D PRESORT,EN1^DIP
25 I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
26 ;
27EXIT ;
28 K ^TMP("RMPO",$J) N RMPRSITE,RMPR D KILL^XUSCLEAN
29 Q
30 ;
31ACTDT() ;*** ACTIVATION DATE
32 S X=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
33 S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
34 Q X
35 ;
36CNT ;*** COUNT NAMES
37 I WHO'=D0 S COUNT=COUNT+1
38 S WHO=D0
39 Q
40 ;
41 ;*** CONVERT DATE FROM FILEMAN FORMAT TO MM/DD/YYYY
42DATE(FMD) ;
43 Q $E(FMD,4,5)_"/"_$E(FMD,6,7)_"/"_($E(FMD,1,3)+1700)
44 ;
45PITEM() ;*** GET PRIMARY ITEM AND ACTIVATION DATE
46 N PITM,E
47 S (E,PITM)=0,X=""
48 F S PITM=$O(^RMPR(665,D0,"RMPOC",PITM)) Q:'PITM D Q:E
49 . S PDT=^RMPR(665,D0,"RMPOC",PITM,0)
50 . Q:$P(PDT,U,11)'="Y"
51 . S X=$P(PDT,U),X=$P(^RMPR(661,X,0),U)
52 . S X=$P($G(^PRC(441,X,0)),U,2)
53 . S X=$E(X,1,30),E=1
54 Q X
55 ;
56PRESORT ;*** SORT BY EXPIRATION DATE
57 N D0,D2,DFN
58 K ^TMP("RMPO",$J)
59 S D2=0
60 F S D2=$O(^RMPR(665,"AHO",D2)) Q:'D2 S D0="" D
61 . F S D0=$O(^RMPR(665,"AHO",D2,D0)) Q:D0="" D
62 . . K VAPA,VADM S DFN=D0 D ^VADPT
63 . . S ^TMP("RMPO",$J,$$RXDT(1),VADM(1),D0)=""
64 Q
65 ;
66RPTHDR ;*** REPORT HEADER
67 N RA S RA=RMPO("NAME"),PAGE=PAGE+1
68 W RPTDT,?(40-($L(RA)/2)),RA,?68,"Page: "_PAGE
69 W !?20,"Prescription Expiration Date",!,"Date Current",!,"Prescription"
70 W !?1,"Expires",?11,"Name",?35,"SSN",?41,"Primary Item",?73,"Active"
71 W !,"==========",?11,"=======================",?35,"====",?41,"==============================",?72,"========",!
72 Q
73 ;
74 ;*** EXPIRATION DATE OF CURRENT RX
75 ; MODE Date format: 0 - MM/DD/YYYY or "N/A" (default)
76 ; 1 - YYYMMDD or "N/A"
77RXDT(MODE) ;
78 N J,D,Y,RA S (D,RA,Y)=""
79 F S D=$O(^RMPR(665,D0,"RMPOB","B",D)) Q:D="" D
80 . S J=$O(^RMPR(665,D0,"RMPOB","B",D,""),-1) Q:J="" S:J>RA RA=J
81 S:RA'="" Y=$P($G(^RMPR(665,D0,"RMPOB",RA,0)),U,3)
82 S X=$S('Y:"N/A",'$G(MODE):$$DATE(Y),1:Y)
83 Q X
84 ;
85SSN() ;*** SOCIAL SECURITY NUMBER
86 K VA,VADM
87 S DFN=D0 D ^VADPT
88 S X=$P(VA("PID"),"-",3)
89 Q X
Note: See TracBrowser for help on using the repository browser.