| [613] | 1 | XUA4A7 ;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.
|
|---|
| 4 | F6S ;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
|
|---|
| 8 | F6S7 ;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
|
|---|
| 13 | F6K Q ;can't delete
|
|---|
| 14 | ;
|
|---|
| 15 | F200S ;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
|
|---|
| 18 | F200K ;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 | ;
|
|---|
| 22 | FE51S ;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
|
|---|
| 30 | FE51K ;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
|
|---|
| 35 | F19S ;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
|
|---|
| 43 | F19K ;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
|
|---|
| 48 | LAYGO ;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
|
|---|
| 58 | L2 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
|
|---|
| 60 | L3 I XU2
|
|---|
| 61 | S X=XU3
|
|---|
| 62 | Q
|
|---|
