XUA4A7 ;ISCSF/RWF - K7, Give entrys into F6 a Provider key ; Oct 17, 2023@03:29:38
;;8.0;KERNEL;**49,542,789**;Jul 10, 1995;Build 15
Q ;don't enter from top.
F6S ;Give provider the key.
N %,X1,X2 S %=$G(^DIC(6,DA,"I")) I %,%<DT Q ;see if inactive
S X1=+$G(^DIC(16,X,"A3")) I 'X1 Q ;get pointer
S %=$O(^DIC(19.1,"B","PROVIDER",0)) I '% Q ;get index
F6S7 ;Kernel 7
I $D(^VA(200,X1,51,%,0)) Q ;allready have it.
N DD,DO,DIC,DS,DA
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.
Q
F6K Q ;can't delete
;
F200S ;name change V6.5 only
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)=""
Q
F200K ;name change V6.5 only
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)
Q
;
FE51S ;Key assignment from new person key subfile
N %,X1,X2 S %=$G(^DIC(19.1,X,0)) Q:$P(%,U,3)'="l" ;see if lookup
S X1=$P($G(^VA(200,DA(1),0)),U) Q:X1="" ;get name
S ^VA(200,"AK."_$P(%,U),X1,DA(1))="" ;set X-ref
Q:%'["PROVIDER" Q:'$D(^DD(3,0))
S X2=+$P($G(^DIC(3,DA(1),0)),U,16) Q:$D(^DIC(6,X2,0)) ;see if in provider file
N DIC,DD,DO,DA,DS,X,Y S DIC="^DIC(6,",DIC(0)="L",DLAYGO=6,(X,DINUM)=X2 D FILE^DICN ;add
Q
FE51K ;Key removal from new person key subfile
N %,X1 S %=$G(^DIC(19.1,X,0)) ;remove incase lookup flag has been removed.
S X1=$P($G(^VA(200,DA(1),0)),U)
K ^VA(200,"AK."_$P(%,U),X1,DA(1))
Q
F19S ;holder subfile assignment V6.5 only
N %,X1,X2 S %=$G(^DIC(19.1,DA(1),0)) Q:$P(%,U,3)'="l" ;see if lookup
S X1=$P($G(^VA(200,X,0)),U) Q:X1="" ;get name
S ^VA(200,"AK."_$P(%,U),X1,X)="" ;set X-ref
Q:%'["PROVIDER"
S X2=+$P($G(^DIC(3,X,0)),U,16) Q:$D(^DIC(6,X2,0)) ;see if in provider file
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
Q
F19K ;holder subfile V6.5 only
S %=$G(^DIC(19.1,DA(1),0)) Q:$P(%,U,3)'="l"
S X1=$P($G(^DIC(3,X,0)),U)
K ^VA(200,"AK."_$P(%,U),X1,X)
Q
LAYGO ;Called from ^DD(200,.01,"LAYGO",1,0)
Q:$G(DIC(0))'["E"
W !,"Checking SOUNDEX for matches."
N DIR,DUOUT,DIRUT,Y,XU1,XU2,XU3 S XU3=X
S X=$$EN^XUA4A71(XU3),XU2=0
F XU1=0:0 S XU1=$O(^VA(200,"ASX",X,XU1)) Q:XU1'>0 D Q:$D(DIRUT)
. W !?5,$P($G(^VA(200,XU1,0)),"^") S XU2=XU2+1
. I '(XU2#16) N X S DIR(0)="E" D ^DIR
. Q
I 'XU2 W !,"No matches found." S XU2=1 G L3
L2 R !,"Do you still want to add this entry: NO//",XU2:DTIME S XU2=$TR($E(XU2_"N"),"NnYy^?","00110?")
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
L3 I XU2
S X=XU3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUA4A7 2720 printed Oct 16, 2024@18:09:42 Page 2
XUA4A7 ;ISCSF/RWF - K7, Give entrys into F6 a Provider key ; Oct 17, 2023@03:29:38
+1 ;;8.0;KERNEL;**49,542,789**;Jul 10, 1995;Build 15
+2 ;don't enter from top.
QUIT
F6S ;Give provider the key.
+1 ;see if inactive
NEW %,X1,X2
SET %=$GET(^DIC(6,DA,"I"))
IF %
IF %<DT
QUIT
+2 ;get pointer
SET X1=+$GET(^DIC(16,X,"A3"))
IF 'X1
QUIT
+3 ;get index
SET %=$ORDER(^DIC(19.1,"B","PROVIDER",0))
IF '%
QUIT
F6S7 ;Kernel 7
+1 ;allready have it.
IF $DATA(^VA(200,X1,51,%,0))
QUIT
+2 NEW DD,DO,DIC,DS,DA
+3 ;give it.
SET DIC="^VA(200,DA(1),51,"
SET DIC(0)="NML"
SET (X,DINUM)=%
SET DA(1)=X1
SET DIC("P")=$PIECE(^DD(200,51,0),"^",2)
DO FILE^DICN
+4 QUIT
F6K ;can't delete
QUIT
+1 ;
F200S ;name change V6.5 only
+1 NEW X1,X2
FOR X1=0:0
SET X1=$ORDER(^DIC(19.1,"D",DA,X1))
if X1'>0
QUIT
SET X2=$GET(^DIC(19.1,X1,0))
IF $PIECE(X2,U,3)="l"
SET ^VA(200,"AK."_$PIECE(X2,U),X,DA)=""
+2 QUIT
F200K ;name change V6.5 only
+1 NEW X1,X2
SET X1="AK."
FOR X2=0:0
SET X1=$ORDER(^VA(200,X1))
if $EXTRACT(X1,1,3)'="AK."
QUIT
KILL ^VA(200,X1,X,DA)
+2 QUIT
+3 ;
FE51S ;Key assignment from new person key subfile
+1 ;see if lookup
NEW %,X1,X2
SET %=$GET(^DIC(19.1,X,0))
if $PIECE(%,U,3)'="l"
QUIT
+2 ;get name
SET X1=$PIECE($GET(^VA(200,DA(1),0)),U)
if X1=""
QUIT
+3 ;set X-ref
SET ^VA(200,"AK."_$PIECE(%,U),X1,DA(1))=""
+4 if %'["PROVIDER"
QUIT
if '$DATA(^DD(3,0))
QUIT
+5 ;see if in provider file
SET X2=+$PIECE($GET(^DIC(3,DA(1),0)),U,16)
if $DATA(^DIC(6,X2,0))
QUIT
+6 ;add
NEW DIC,DD,DO,DA,DS,X,Y
SET DIC="^DIC(6,"
SET DIC(0)="L"
SET DLAYGO=6
SET (X,DINUM)=X2
DO FILE^DICN
+7 QUIT
FE51K ;Key removal from new person key subfile
+1 ;remove incase lookup flag has been removed.
NEW %,X1
SET %=$GET(^DIC(19.1,X,0))
+2 SET X1=$PIECE($GET(^VA(200,DA(1),0)),U)
+3 KILL ^VA(200,"AK."_$PIECE(%,U),X1,DA(1))
+4 QUIT
F19S ;holder subfile assignment V6.5 only
+1 ;see if lookup
NEW %,X1,X2
SET %=$GET(^DIC(19.1,DA(1),0))
if $PIECE(%,U,3)'="l"
QUIT
+2 ;get name
SET X1=$PIECE($GET(^VA(200,X,0)),U)
if X1=""
QUIT
+3 ;set X-ref
SET ^VA(200,"AK."_$PIECE(%,U),X1,X)=""
+4 if %'["PROVIDER"
QUIT
+5 ;see if in provider file
SET X2=+$PIECE($GET(^DIC(3,X,0)),U,16)
if $DATA(^DIC(6,X2,0))
QUIT
+6 ;add
NEW DIC,DD,DO,DA,DS,X,Y
SET X=X2
SET DIC="^DIC(6,"
SET DIC(0)="L"
SET DLAYGO=6
SET DINUM=X2
DO FILE^DICN
+7 QUIT
F19K ;holder subfile V6.5 only
+1 SET %=$GET(^DIC(19.1,DA(1),0))
if $PIECE(%,U,3)'="l"
QUIT
+2 SET X1=$PIECE($GET(^DIC(3,X,0)),U)
+3 KILL ^VA(200,"AK."_$PIECE(%,U),X1,X)
+4 QUIT
LAYGO ;Called from ^DD(200,.01,"LAYGO",1,0)
+1 if $GET(DIC(0))'["E"
QUIT
+2 WRITE !,"Checking SOUNDEX for matches."
+3 NEW DIR,DUOUT,DIRUT,Y,XU1,XU2,XU3
SET XU3=X
+4 SET X=$$EN^XUA4A71(XU3)
SET XU2=0
+5 FOR XU1=0:0
SET XU1=$ORDER(^VA(200,"ASX",X,XU1))
if XU1'>0
QUIT
Begin DoDot:1
+6 WRITE !?5,$PIECE($GET(^VA(200,XU1,0)),"^")
SET XU2=XU2+1
+7 IF '(XU2#16)
NEW X
SET DIR(0)="E"
DO ^DIR
+8 QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+9 IF 'XU2
WRITE !,"No matches found."
SET XU2=1
GOTO L3
L2 READ !,"Do you still want to add this entry: NO//",XU2:DTIME
SET XU2=$TRANSLATE($EXTRACT(XU2_"N"),"NnYy^?","00110?")
+1 IF "01"'[XU2
WRITE !?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."
GOTO L2
L3 IF XU2
+1 SET X=XU3
+2 QUIT
