source: WorldVistAEHR/trunk/r/PHARMACY_PRESCRIPTION_PRACTICE-PPP/PPPEDT22.m@ 724

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

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1PPPEDT22 ;ALB/JFP - EDIT FF XREF ROUTINE ;5/19/92
2 ;;V1.0;PHARMACY PRESCRIPTION PRACTICE;;APR 7,1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routines control the changing of domains in the foreign facility
6 ; file.
7 ;
8CHNG ; -- EDIT FFX data
9 ;
10 N SNIFN2,PPPDOM,NEWDOM,OLDDOM
11 N VALMY,SDI,SDAT,FFXIFN
12 ;
13 D EN^VALM2($G(XQORNOD(0)),"O")
14 Q:'$D(VALMY)
15 S SDI=""
16 F S SDI=$O(VALMY(SDI)) Q:SDI="" D
17 .S SDAT=$G(@IDXARRAY@(SDI))
18 .S SNIFN2=$P(SDAT,"@",2)
19 .S FFXIFN=$P(SDAT,"@",3)
20 .S OLDDOM=$P(SDAT,"@",4)
21 .D EDIT1
22 D INIT^PPPEDT21
23 S VALMBCK="R"
24 Q
25 ;
26EDIT1 ; -- Edits entry in FFX file
27 N NEWTO
28 ;
29 S PPPDOM=$$GETDOM^PPPGET3(+SNIFN2)
30 S NEWTO=$S(PPPDOM=" ":" ?? for choices",1:" ")
31 S DIR(0)="P^4.2:EQM"
32 S DIR("A")="Change Domain Name in entry "_SDI_" from "_OLDDOM_" to"_NEWTO
33 S DIR("B")=$S(PPPDOM'=" ":PPPDOM,1:"??")
34 S DIR("?")="^D CLEAR^VALM1,HLPDOM1^PPPHLP01"
35 S DIR("??")="^D CLEAR^VALM1,HLPD1^PPPHLP01"
36 D ^DIR
37 I $D(DIRUT) Q
38 S NEWDOM=$P(Y,"^",2)
39 K DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
40 ;
41 I OLDDOM'=NEWDOM D Q
42 .S $P(^PPP(1020.2,FFXIFN,1),"^",5)=NEWDOM
43 Q
44 ;
45CHNGA ; -- Changes all entries
46 ;
47 N SNIFN2,PPPDOM,NEWDOM,OLDDOM
48 N SDI,SDAT,FFXIFN
49 Q:'$D(^TMP("PPPIDX"))
50 ;
51 S PPPDOM=$$GETDOM^PPPGET3(+SNIFN) ; original institution
52 S DIR(0)="P^4.2:EQM"
53 S DIR("A")="Change ALL Domain Name listed to"
54 S DIR("B")=$S(PPPDOM'=" ":PPPDOM,1:"Domain not found")
55 S DIR("?")="^D CLEAR^VALM1,HLPDOM1^PPPHLP01"
56 S DIR("??")="^D CLEAR^VALM1,HLPD1^PPPHLP01"
57 D ^DIR
58 I $D(DIRUT) Q
59 S NEWDOM=$P(Y,"^",2)
60 K DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
61 ;
62 S SDI=""
63 F S SDI=$O(^TMP("PPPIDX",$J,SDI)) Q:SDI="" D
64 .S SDAT=$G(@IDXARRAY@(SDI))
65 .S SNIFN2=$P(SDAT,"@",2)
66 .S FFXIFN=$P(SDAT,"@",3)
67 .S OLDDOM=$P(SDAT,"@",4)
68 .I OLDDOM'=NEWDOM D Q
69 ..S $P(^PPP(1020.2,FFXIFN,1),"^",5)=NEWDOM
70 D INIT^PPPEDT21
71 S VALMBCK="R"
72 Q
73 ;
74END ; -- End of code
75 Q
76 ;
Note: See TracBrowser for help on using the repository browser.