source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPPRT21.m@ 1800

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1PPPPRT21 ;ALB/DMB - FFX PRINT ROUTINES ; 3/13/92
2 ;;V1.0;PHARMACY PRESCRIPTION PRACTICE;**10**;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PRTBYSTA ; Print the FFX file by station
6 ;
7 N PPPARRY,PPPMRT,DROOT,HROOT,PRTFFXST,PRTFFXND,BLINE,X,TMP
8 N PATNAME,PATINFO,PATDOB,PATSSN
9 N STANAME,STAINFO,STANUM,DOMAIN,LDOV
10 N HDRCNT
11 ;
12 S (VALMCNT,HDRCNT)=0
13 ;
14 S DROOT="^TMP(""PPPL6"",$J)"
15 S HROOT="^TMP(""PPPL6"",$J,""HDR"")"
16 S PPPARRY="^TMP(""PPP"",$J,""SRT"")"
17 ;
18 K @DROOT,@HROOT,@PPPARRY
19 ;
20 S PPPMRT="PRTBYSTA_PPPPRT21"
21 S PRTFFXST=1017
22 S PRTFFXND=1018
23 ;
24 S TMP=$$LOGEVNT^PPPMSC1(PRTFFXST,PPPMRT)
25 ;
26 D HDR2
27 S TMP=$$SRTBYSTA^PPPPRT4(PPPARRY) ; -- Sorts data
28 D ORDER1
29 S TMP=$$LOGEVNT^PPPMSC1(PRTFFXND,PPPMRT)
30 ; -- Clean up
31 K DIR,DIE
32 K @PPPARRY
33 Q
34 ;
35HDR2 ; Write the heading
36 ;
37 S BLINE=$$SETSTR^VALM1(" ","",1,80)
38 ;
39 S X=$$CENTER^PPPUTL1(BLINE,"PPP Foreign Facility Xref File")
40 D TMPHDR
41 S X=$$CENTER^PPPUTL1(BLINE,"by station as of --> "_$$I2EDT^PPPCNV1(DT))
42 D TMPHDR
43 S X=" " D TMPHDR
44 S X=$$SETSTR^VALM1("FACILITY NAME","",1,45)
45 S X=$$SETSTR^VALM1("NUMBER",X,46,15)
46 S X=$$SETSTR^VALM1("DOMAIN",X,61,20)
47 D TMPHDR
48 S X=$$SETSTR^VALM1("PATIENT NAME","",2,28)
49 S X=$$SETSTR^VALM1("SSN",X,31,15)
50 S X=$$SETSTR^VALM1("DOB",X,46,15)
51 S X=$$SETSTR^VALM1("LAST VISIT",X,61,20)
52 D TMPHDR
53 Q
54 ;
55ORDER1 ; -- First line
56 ;
57 S STANAME=""
58 F I1=0:0 D Q:STANAME=""
59 .S STANAME=$O(@PPPARRY@(STANAME)) Q:STANAME=""
60 .S STAINFO=@PPPARRY@(STANAME) Q:STAINFO=""
61 .S STANUM=$P(STAINFO,"^")
62 .S DOMAIN=$E($P(STAINFO,"^",2),1,18)
63 .S X=$$SETSTR^VALM1(STANAME,"",1,45)
64 .S X=$$SETSTR^VALM1(STANUM,X,46,15)
65 .S X=$$SETSTR^VALM1(DOMAIN,X,61,20)
66 .D TMP
67 .;
68ORDER2 .; -- Second line
69 .;
70 .S PATNAME=""
71 .F I2=0:0 D Q:PATNAME=""
72 ..S PATNAME=$O(@PPPARRY@(STANAME,PATNAME)) Q:PATNAME=""
73 ..S PATINFO=@PPPARRY@(STANAME,PATNAME) Q:PATINFO=""
74 ..S PATDOB=$P(PATINFO,"^")
75 ..S PATSSN=$P(PATINFO,"^",2)
76 ..S LDOV=$P(PATINFO,"^",3)
77 ..S X=$$SETSTR^VALM1(PATNAME,"",2,28)
78 ..S X=$$SETSTR^VALM1($E(PATSSN,1,3)_"-"_$E(PATSSN,4,5)_"-"_$E(PATSSN,6,9),X,31,15)
79 ..S X=$$SETSTR^VALM1(PATDOB,X,46,15)
80 ..S X=$$SETSTR^VALM1(LDOV,X,61,20)
81 ..D TMP
82 .S X=$$SETSTR^VALM1(" ","",1,80) D TMP ; -- null line
83 Q
84 ;
85TMP ; -- Sets up data display array
86 S VALMCNT=VALMCNT+1
87 S @DROOT@(VALMCNT,0)=$E(X,1,79)
88 QUIT
89 ;
90TMPHDR ; -- Sets up header display array
91 S HDRCNT=HDRCNT+1
92 S @HROOT@(HDRCNT)=$E(X,1,79)
93 QUIT
94 ;
95ERRMSG ;Error message
96 I $G(@PHRMARRY@(RVRSDT,STAPTR,"PID")) S PID=@PHRMARRY@(RVRSDT,STAPTR,"PID") D
97 .S PIDNAM=$P(PID,"^",1),Y=$P(PID,"^",3) X ^DD("DD") S PIDDOB=Y,PIDSSN=$P(PID,"^",2)
98 .I PIDNAM'=PPPNAME W !!," ** WARNING ** Patient's Name ",PIDNAME," does not match ",PPPNAME
99 .I PIDSSN'=PPPSSN W !," ** WARNING ** Patient's SSN ",PIDSSN," does not match ",PPPSSN
100 .I PIDDOB'=PPPDOB W !," ** WARNING ** Patient's DOB ",PIDDOB," does not match ",PPPDOB
101 .K PIDDOB,PIDNAM,@PHRMARRY@(RVRSDT,STAPTR,"PID")
102 Q
Note: See TracBrowser for help on using the repository browser.