source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPFMX.m@ 1073

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1PPPFMX ;ALB/DMB/DAD - FILEMAN UTILITIES FOR PPP ; 1/10/92
2 ;;1.0;PHARMACY PRESCRIPTION PRACTICE;**26,39**;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5SDFNPOV ;
6 N PPPDFN
7 ;S VAQFLAG=1
8 S PPPDFN=$P($G(^PPP(1020.2,DA,0)),"^",1)
9 Q:PPPDFN=""
10 S ^PPP(1020.2,"APOV",PPPDFN,X,DA)=""
11 S ^PPP(1020.2,"ARPOV",X,PPPDFN,DA)=""
12 Q
13 ;
14KDFNPOV ;
15 N PPPDFN
16 S PPPDFN=$P($G(^PPP(1020.2,DA,0)),"^",1)
17 Q:PPPDFN=""
18 K:$D(^PPP(1020.2,"APOV",PPPDFN,X,DA)) ^PPP(1020.2,"APOV",PPPDFN,X,DA)
19 ;VMP OIFO BAY PINES;VGF;PPP*1*39
20 ;CORRECTED THE FOLLOWING KILL COMMAND
21 K:$D(^PPP(1020.2,"ARPOV",X,PPPDFN,DA)) ^PPP(1020.2,"ARPOV",X,PPPDFN,DA)
22 Q
23 ;
24SDFNDT ;
25 N PPPDFN
26 S PPPDFN=$P($G(^PPP(1020.2,DA,0)),"^",1)
27 Q:PPPDFN=""
28 S ^PPP(1020.2,"ADT",PPPDFN,X,DA)=""
29 Q
30 ;
31KDFNDT ;
32 N PPPDFN
33 S PPPDFN=$P($G(^PPP(1020.2,DA,0)),"^",1)
34 Q:PPPDFN=""
35 K:$D(^PPP(1020.2,"ADT",PPPDFN,X,DA)) ^PPP(1020.2,"ADT",PPPDFN,X,DA)
36 Q
37 ;
38SNSSN ;
39 N PPPNOD0,PPPTR
40 N ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTSAVE
41 ;
42 ; Check that this is either an edit or a new entry to avoid
43 ; setting during a re-index of the Patient file.
44 ; PPPOK is defined in the kill logic below if the new entry
45 ; does not equal the old.
46 ; DPTDFN is defined in the Patient Registration routines.
47 ;
48 I ($D(PPPOK))!($D(DPTDFN)) D
49 .S PPPNOD0=$G(^PPP(1020.7,0))
50 .Q:PPPNOD0=""
51 .;
52 .; Get the File Descriptor Node for updating.
53 .;
54 .S PPPTR=$P(PPPNOD0,"^",4)
55 .;
56 .; Set the entry and the "B" Xref
57 .;
58 .S ^PPP(1020.7,DA,0)=PPP
59 .S ^PPP(1020.7,"B",PPP,DA)=""
60 .;
61 .; Update the Descriptor node.
62 .;
63 .S $P(PPPNOD0,"^",3)=DA
64 .S $P(PPPNOD0,"^",4)=PPPTR+1
65 .S ^PPP(1020.7,0)=PPPNOD0
66 .;
67 .; Task out the MPD lookup.
68 .;PPP*1*26 Dave Blocker : Remove MPD access attempt
69 .;because the PPP BATCH job will do the MPD request each night.
70 .Q
71 Q
72 ;
73KNSSN ;
74 N PPPNOD0
75 ;
76 ; Check that this is an edit and not a re-index.
77 ;
78 S X="I PPP'=$P($G(^"_"DPT("_DA_","_"0)),"_"""^"""_",9) S PPPERR=1" X X I $G(PPPERR)=1 K PPPERR D
79 .S PPPOK=1
80 .;
81 .; Check that the node currently exists, kill it if it does.
82 .;
83 .I $D(^PPP(1020.7,"B",PPP)) D
84 ..K:$D(^PPP(1020.7,DA)) ^PPP(1020.7,DA)
85 ..K:$D(^PPP(1020.7,"B",PPP,DA)) ^PPP(1020.7,"B",PPP,DA)
86 ..;
87 ..; If the record count is alredy 0 then quit.
88 ..;
89 ..S PPPNOD0=^PPP(1020.7,0)
90 ..Q:+$P(PPPNOD0,"^",4)=0
91 ..S $P(PPPNOD0,"^",4)=$P(PPPNOD0,"^",4)-1
92 ..S ^PPP(1020.7,0)=PPPNOD0
93 Q
94 ;
95DOMAIN(IFN) ; Find domain name from institution number to stuff into #1.5.
96 ;
97 ; Get the station number from the institution file
98 ; to resolve domain
99 ;
100 ; Input: IFN -- Pointer to record in #1020.2
101 ; Output: Domain name in field #1.5
102 ;
103 ;VMP OIFO BAY PINES;VGF;PPP*1.0*39
104 N PPPINST,PPPIEN
105 S PPPINST=+$P($G(^PPP(1020.2,IFN,0)),"^",2)
106 S PPPIEN=$O(^PPP(1020.8,"B",PPPINST,0))
107 Q $$GET1^DIQ(1020.8,PPPIEN_",",.02)
108 ;
Note: See TracBrowser for help on using the repository browser.