source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPORLP.m@ 1552

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

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1RMPORLP ;(NG)/DG/CAP /HINES-CIOFO/HNC- HOME OXY PTS ;7/24/98
2 ;;3.0;PROSTHETICS;**29**;Feb 09, 1996
3 ;
4SITE ;Set up site variables.
5 D HOSITE^RMPOUTL0 I '$D(RMPOXITE) Q
6 ;
7LI ;List the sought patient. ;DW
8 S DIC="^RMPR(665,",BY="[RMPO-RPT-HOPATIENTLIST]",L=0,FR=""
9 S PAGE=0
10 S DIS(0)="S Z=$G(^RMPR(665,D0,""RMPOA"")) I ($P(Z,U,7)=RMPOXITE),$P(Z,U,3)="""""
11 ;S DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE",PAGE=0
12 S $P(SPACE," ",80)="",$P(DASH,"-",79)="",(COUNT,RMEND,RMPORPT)=0
13 D NOW^%DTC S Y=% X ^DD("DD")
14 S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
15 S DHD="W ?0 D RPTHDR^RMPORLP"
16 S DIOEND="I $G(Y)'[U S COUNT=$E("" "",1,(6-$L(COUNT)))_COUNT W !!,?50,""TOTAL PATIENTS: "",COUNT S RMEND=1 S:IOST[""P-"" RMPORPT=1"
17 ;S DIOEND="I $G(Y)'[U D DIOEND S RMEND=1 S:IOST[""P-"" RMPORPT=1"
18 S FLDS=".01;C1;L22;""PATIENT"",D SSN^RMPORLP W X;C25;L4;""SSN"",D GET^RMPORLP W X;C30;L30;""PRIMARY ITEM"""
19 S FLDS(2)="D SDT^RMPORLP W X;C61;L8;""START"",D EDT^RMPORLP W X;C70;""EXPIRE"""
20 D EN1^DIP
21 I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
22EXIT ;
23 K ^TMP($J)
24 N RMPRSITE,RMPR D KILL^XUSCLEAN
25 Q
26DIOEND ;
27 S COUNT=$E(" ",1,(6-$L(COUNT)))_COUNT
28 W !!,?50,"Total Patients: ",COUNT
29 Q
30CNT ;COUNT NAMES
31 I X'="" S COUNT=COUNT+1
32 Q
33GET ;Get the primary item. ;DW
34 S X="" N RR,RA S (RR,RA)=0
35 F S RA=$O(^RMPR(665,D0,"RMPOC",RA)) Q:RA="" I $P($G(^RMPR(665,D0,"RMPOC",RA,0)),U,11)="Y" D Q
36 . ; PROSTHETICS PATIENT FILE
37 . S RR=$P(^RMPR(665,D0,"RMPOC",RA,0),U)
38 . ;PROS ITEM FILE
39 . S RR=$P(^RMPR(661,RR,0),U)
40 . ; ITEM MASTER FILE
41 . S RR=$P(^PRC(441,RR,0),"^",2)
42 . S X=$E(RR,1,30)
43 Q
44 ;
45SSN ;GET SSN
46 S X=""
47 K VA,VADM S DFN=D0 D ^VADPT
48 S X=$P(VA("PID"),"-",3)
49 D CNT
50 Q
51SDT ;GET START DATE (USE INITIAL OXYGEN RX DATE)
52 S X="" N RA
53 S RA=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
54 I RA S X=$E(RA,4,5)_"/"_$E(RA,6,7)_"/"_$E(RA,2,3)
55 Q
56EDT ;Expiration Date of current Rx.
57 N J,D,Y,RA S (J,Y,X,D,RA)=""
58 F S D=$O(^RMPR(665,D0,"RMPOB","B",D)) Q:D="" D
59 . S J="",J=$O(^RMPR(665,D0,"RMPOB","B",D,J)) Q:J="" S:(J>RA) RA=J
60 ;I J="" Q
61 I RA="" Q
62 S Y=$P($G(^RMPR(665,D0,"RMPOB",RA,0)),U,3)
63 I Y S X=X_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)
64 Q
65EDTX ;Rx Expiration Date.
66 ;Get the expiration dates for all active Rx.
67 N J,D,EDT,C,TD S (J,D,EDT,C,X)=""
68 ; Get today's date.
69 D NOW^%DTC S TD=X,X=""
70 ; Get the active Rx.
71 F S D=$O(^RMPR(665,D0,"RMPOB","B",D)) Q:D="" S C=C+1 D
72 .F S J=$O(^RMPR(665,D0,"RMPOB","B",D,J)) Q:J="" D
73 .. S EDT=$P($G(^RMPR(665,D0,"RMPOB",J,0)),U,3)
74 .. I EDT S X=X_$E(EDT,4,5)_"/"_$E(EDT,6,7)_"/"_($E(EDT,1,3)+1700)_" "
75 ; Define the other dates.
76 I C="" S X="N/A" Q
77 Q
78RPTHDR ;Report header
79 N RA S RA=RMPO("NAME"),PAGE=PAGE+1
80 W RPTDT,?(40-($L(RA)/2)),RA,?68,"Page: "_PAGE
81 W !?22,"Alphabetical List Home Oxygen Patients",!?68,"Date Current",!?68,"Prescription"
82 W !,"Patient",?25,"SSN",?29,"Primary Item",?61,"Active",?70,"Expires"
83 W !,"=======================",?24,"====",?29,"==============================",?60,"======== ==========",!
84 Q
Note: See TracBrowser for help on using the repository browser.