source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUA4A7.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: 2.6 KB
Line 
1XUA4A7 ;ISCSF/RWF - K7, Give entrys into F6 a Provider key ;1/15/97 09:42
2 ;;8.0;KERNEL;**49**;Jul 10, 1995
3 Q ;don't enter from top.
4F6S ;Give provider the key.
5 N %,X1,X2 S %=$G(^DIC(6,DA,"I")) I %,%<DT Q ;see if inactive
6 S X1=+$G(^DIC(16,X,"A3")) I 'X1 Q ;get pointer
7 S %=$O(^DIC(19.1,"B","PROVIDER",0)) I '% Q ;get index
8F6S7 ;Kernel 7
9 I $D(^VA(200,X1,51,%,0)) Q ;allready have it.
10 N DD,DO,DIC,DS,DA
11 S DIC="^VA(200,DA(1),51,",DIC(0)="NML",(X,DINUM)=%,DA(1)=X1,DIC("P")=$P(^DD(200,51,0),"^",2) D FILE^DICN ;give it.
12 Q
13F6K Q ;can't delete
14 ;
15F200S ;name change V6.5 only
16 N X1,X2 F X1=0:0 S X1=$O(^DIC(19.1,"D",DA,X1)) Q:X1'>0 S X2=$G(^DIC(19.1,X1,0)) I $P(X2,U,3)="l" S ^VA(200,"AK."_$P(X2,U),X,DA)=""
17 Q
18F200K ;name change V6.5 only
19 N X1,X2 S X1="AK." F X2=0:0 S X1=$O(^VA(200,X1)) Q:$E(X1,1,3)'="AK." K ^VA(200,X1,X,DA)
20 Q
21 ;
22FE51S ;Key assignment from new person key subfile
23 N %,X1,X2 S %=$G(^DIC(19.1,X,0)) Q:$P(%,U,3)'="l" ;see if lookup
24 S X1=$P($G(^VA(200,DA(1),0)),U) Q:X1="" ;get name
25 S ^VA(200,"AK."_$P(%,U),X1,DA(1))="" ;set X-ref
26 Q:%'["PROVIDER" Q:'$D(^DD(3,0))
27 S X2=+$P($G(^DIC(3,DA(1),0)),U,16) Q:$D(^DIC(6,X2,0)) ;see if in provider file
28 N DIC,DD,DO,DA,DS,X,Y S DIC="^DIC(6,",DIC(0)="L",DLAYGO=6,(X,DINUM)=X2 D FILE^DICN ;add
29 Q
30FE51K ;Key removal from new person key subfile
31 N %,X1 S %=$G(^DIC(19.1,X,0)) ;remove incase lookup flag has been removed.
32 S X1=$P($G(^VA(200,DA(1),0)),U)
33 K ^VA(200,"AK."_$P(%,U),X1,DA(1))
34 Q
35F19S ;holder subfile assignment V6.5 only
36 N %,X1,X2 S %=$G(^DIC(19.1,DA(1),0)) Q:$P(%,U,3)'="l" ;see if lookup
37 S X1=$P($G(^VA(200,X,0)),U) Q:X1="" ;get name
38 S ^VA(200,"AK."_$P(%,U),X1,X)="" ;set X-ref
39 Q:%'["PROVIDER"
40 S X2=+$P($G(^DIC(3,X,0)),U,16) Q:$D(^DIC(6,X2,0)) ;see if in provider file
41 N DIC,DD,DO,DA,DS,X,Y S X=X2,DIC="^DIC(6,",DIC(0)="L",DLAYGO=6,DINUM=X2 D FILE^DICN ;add
42 Q
43F19K ;holder subfile V6.5 only
44 S %=$G(^DIC(19.1,DA(1),0)) Q:$P(%,U,3)'="l"
45 S X1=$P($G(^DIC(3,X,0)),U)
46 K ^VA(200,"AK."_$P(%,U),X1,X)
47 Q
48LAYGO ;Called from ^DD(200,.01,"LAYGO",1,0)
49 Q:DIC(0)'["E"
50 W !,"Checking SOUNDEX for matches."
51 N %,XU1,XU2,XU3 S XU3=X
52 S X=$$EN^XUA4A71(XU3),XU2=0
53 F XU1=0:0 S XU1=$O(^VA(200,"ASX",X,XU1)) Q:XU1'>0 D
54 . W !?5,$P($G(^VA(200,XU1,0)),"^") S XU2=XU2+1
55 . I '(XU2#16) R !,"Press Return to Continue. ",%:DTIME
56 . Q
57 I 'XU2 W !,"No matches found." S XU2=1 G L3
58L2 R !,"Do you still want to add this entry: NO//",XU2:300 S XU2=$TR($E(XU2_"N"),"NnYy^?","00110?")
59 I "01"'[XU2 W !?4,"Answer NO to stop the addition of ",XU3," as a new person.",!?4,"Answer YES to add, a '^' will be taken as a NO." G L2
60L3 I XU2
61 S X=XU3
62 Q
Note: See TracBrowser for help on using the repository browser.