Cache for OpenVMS/ALPHA V7.x^INT^FOR FILEMAN TUTORIAL^~Format=Cache.S~
%RO on 04 Dec 2006  12:01 PM
A6AKIT^INT^1^60143,64595^0
A6AKIT ;SFISC/MKO-SET UP TEST FILE FOR KEY AND INDEX TUTORIAL ;4:06 PM  5 Mar 2001
 ;;1.0;KEY AND INDEX TUTORIAL;Mar 1, 2001
 N A6AFL,A6AGL,A6ASFL
 I $G(DUZ(0))'="@" D  Q
 . W $C(7),!,"You must be a programmer to run this utility."
 ;
 D INIZE^DIEFU,HOME^%ZIS
 ;
 ;Get file name and number
 S A6AFL=$$FL Q:A6AFL<0
 ;
 ;If selected an existing file, ask whether to delete it first
 I '$P(A6AFL,U,3) D  Q:A6AGL=""
 . S A6AGL=$G(^DIC(+A6AFL,0,"GL")) Q:A6AGL=""
 . I '$$ASKDEL(A6AFL) S A6AGL="" Q
 . D REP(A6AFL,A6AGL)
 ;
 ;Otherwise, this is a new file
 E  S A6AGL=$$GL(A6AFL) Q:A6AGL=""
 ;
 ;Set DD and data
 S A6ASFL=+A6AFL_$E(".",+A6AFL'[".")_"02"
 D DD^A6AKIT1(+A6AFL,A6ASFL)
 D DATA^A6AKIT2(A6AGL,A6ASFL)
 ;
 W !!,"File created: "_$P(A6AFL,U,2)_" (#"_+A6AFL_")"
 W !," Global root: "_A6AGL
 W !!,"DONE!!"
 Q
 ;
FL() ;Get file name and number
 N DA,DLAYGO,DIC,DILN,DTOUT,DUOUT,I,X,Y,Z
 ;
 W !,"I am going to set up a test file for the FileMan V. 22.0 Key and Index"
 W !,"tutorial."
 W !!,"The tutorial assumes the name of the test file is ZZINDIVIDUAL and the"
 W !,"number of the test file is 662nnn, but you can choose any name and number"
 W !,"you wish.",!
 ;
 S DLAYGO=1
 S DIC="^DIC(",DIC(0)="QEAXLI"
 S DIC("A")="Name of test file: "
 S DIC("B")="ZZINDIVIDUAL"
 S DIC("S")="I Y'<2 S DIFILE=+Y,DIAC=""DD"" D ^DIAC I %"
 S DIC("W")=$P($T(W),";;",2,999)
 D ^DIC
 Q Y
W ;;W:$X>53 !?9 I Y-1.1,Y-.6,$D(^DIC(Y,0,"GL")),^("GL")'["[",$D(@(^("GL")_"0)")) S %=+$P(^(0),U,4) W ?40,"  ("_%_" entr"_$P("ies^y",U,%=1+1)_")"
 ;
GL(Y) ;Get global root of file
 Q:'$P(Y,U,3) $G(^DIC(+Y,0,"GL"))
 N %,DA,DG,DIC,DIE,DIK,DLAYGO,F,X,Z
 D DIE^DIB
 Q $G(DG)
 ;
ASKDEL(A6AFL) ;Ask whether to delete file
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y,A6ADEV,A6AMSG,DIERR
 ;
 ;Make sure this looks like the test file
 D
 . Q:'$D(^DD(+A6AFL,"B","AREA CODE",3.1))
 . Q:'$D(^DD(+A6AFL,"B","DATE CREATED",4.1))
 . Q:'$D(^DD(+A6AFL,"B","DOB",.03))
 . Q:'$D(^DD(+A6AFL,"B","EMAIL",2))
 . Q:'$D(^DD(+A6AFL,"B","LOCAL NUMBER",3.2))
 . Q:'$D(^DD(+A6AFL,"B","OLD PHONE NUMBER",3.4))
 . Q:'$D(^DD(+A6AFL,"B","PHONE NUMBER",3.3))
 . Q:'$D(^DD(+A6AFL,"B","SSN",.02))
 . S Y=1
 I '$G(Y) D  Q 0
 . W !!,$C(7)_"  The file you have selected doesn't look like the Key and Index Tutorial"
 . W !,"  test file. The A6AKIT utility cannot be used to delete it. Please use"
 . W !,"  FileMan's Edit File option on the Utility Functions menu to delete it,"
 . W !,"  or select a different file.",!
 ;
 ;Ask whether to delete the old file.
 S A6ADEV=$$GET1^DID(+A6AFL,"","","DEVELOPER","","A6AMSG")
 S:A6ADEV?." " A6ADEV="<unknown>"
 W !!,"  NOTE: You've selected an existing Key and Index Tutorial test file."
 W !!,"                File: "_$P(A6AFL,U,2)_" (#"_+A6AFL_")"
 W !,"          Created by: "_A6ADEV
 W !!,"        You can choose to delete it and replace it with the original version"
 W !,"        of the file."
 S DIR(0)="Y"
 S DIR("A")="Delete and replace "_$P(A6AFL,U,2)_" File (#"_+A6AFL_")"
 S DIR("B")="NO"
 S DIR("?",1)="  Answer 'YES' if you would like to delete the file, and replace it with"
 S DIR("?",2)="  the original version of the test file."
 S DIR("?",3)=""
 S DIR("?")="  Answer 'NO' to quit."
 W ! D ^DIR
 Q Y
 ;
REP(A6AFL,A6AGL) ;Replace file
 ;Delete
 N %,DA,DIC,DLAYGO,DIU,X,Y,Z
 S DIU=+A6AFL,DIU(0)="DT"
 D EN^DIU2
 ;
 ;Create
 S DLAYGO=1
 S DIC="^DIC(",DIC(0)="QLXI"
 S X=$P(A6AFL,U,2),DINUM=+A6AFL
 D FILE^DICN
 ;
 S $P(^DIC(+A6AFL,0),U,2)=+A6AFL,^("%A")=DUZ_U_DT,^(0,"GL")=A6AGL
 F %="DD","DEL","RD","WR","LAYGO","AUDIT" S ^DIC(+A6AFL,0,%)="@"
 S ^DD(+A6AFL,0)="FIELD^^0^0"
 S @(A6AGL_"0)")=$P(A6AFL,U,2)_U_+A6AFL
 Q
 ;
MODENT(A6AFILE) ;Establishes a starting point for
 ;OLD PHONE NUMBER and PHONE NUMBER
 N A6AFDA,A6AIENS
 ;
 ;Lookup MODIFIED ENTRY
 S A6AIENS=$$FIND1^DIC(A6AFILE,"","QX","MODIFIED,ENTRY","B")_","
 I $G(A6AIENS)'>0 D  Q
 . I $G(DIERR) D MSG^DIALOG() Q
 . I $P(A6AIENS,",")=0 W !,"MODIFIED,ENTRY not found."
 ;
 S A6AFDA(A6AFILE,A6AIENS,3.1)=111
 S A6AFDA(A6AFILE,A6AIENS,3.2)="111-1111"
 D FILE^DIE("","A6AFDA") I $G(DIERR) D MSG^DIALOG() Q
 ;
 S A6AFDA(A6AFILE,A6AIENS,3.1)=415
 S A6AFDA(A6AFILE,A6AIENS,3.2)="555-1234"
 D FILE^DIE("","A6AFDA") I $G(DIERR) D MSG^DIALOG() Q
 ;
 D INQ(A6AFILE,+A6AIENS)
 Q
 ;
INQ(A6AFILE,A6AIEN) ;Inquire
 N A,D0,DK,S,Y,DIC,DA,DR,DIQ
 S DIC=$S($G(A6AFILE):$G(^DIC(A6AFILE,0,"GL")),1:$G(A6AFILE))
 Q:$G(DIC)=""
 S DA=+A6AIEN,DIQ(0)="R"
 D EN^DIQ
 Q

A6AKIT1^INT^1^60143,64595^0
A6AKIT1 ;SFISC/MKO-DD FOR ZZINDIVIDUAL FILE ;11:10 AM  1 Mar 2001
 ;;1.0;KEY AND INDEX TUTORIAL;Mar 1, 2001
DD(A6AFIL,A6ASFL) ;Build DD
 N I,X,Y,Z
 ;
 F I=1:2 S X=$T(Q+I) Q:X=""  D
 . S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999)
 . S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99)
 . S:$A(Y)=61 Y=$E(Y,2,999)
 . F  Q:Y'["A6ASFL"  S Y=$P(Y,"A6ASFL")_A6ASFL_$P(Y,"A6ASFL",2,999)
 . F  Q:Y'["A6AFIL"  S Y=$P(Y,"A6AFIL")_A6AFIL_$P(Y,"A6AFIL",2,999)
 . S @X=Y
 N DA,DIC,DIK
 S DIK="^DD("_A6AFIL_",",DA(1)=A6AFIL D IXALL^DIK K DIK,DA
 S DIK="^DD("_A6ASFL_",",DA(1)=A6ASFL D IXALL^DIK K DIK,DA
Q Q
 ;;^DD(A6AFIL,.01,0)
 ;;=NAME^RF^^0;1^K:$L(X)>30!($L(X)<3)!'(X'?1P.E) X
 ;;^DD(A6AFIL,.01,1,0)
 ;;=^.1
 ;;^DD(A6AFIL,.01,1,1,0)
 ;;=A6AFIL^B
 ;;^DD(A6AFIL,.01,1,1,1)
 ;;=S ^DIZ(A6AFIL,"B",$E(X,1,30),DA)=""
 ;;^DD(A6AFIL,.01,1,1,2)
 ;;=K ^DIZ(A6AFIL,"B",$E(X,1,30),DA)
 ;;^DD(A6AFIL,.01,3)
 ;;=Answer must be 3-30 characters in length.
 ;;^DD(A6AFIL,.02,0)
 ;;=SSN^F^^0;2^K:$L(X)>9!($L(X)<9)!'(X?9N) X
 ;;^DD(A6AFIL,.02,3)
 ;;=Answer must be 9 characters in length.
 ;;^DD(A6AFIL,.03,0)
 ;;=DOB^D^^0;3^S %DT="EX" D ^%DT S X=Y K:Y<1 X
 ;;^DD(A6AFIL,2,0)
 ;;=EMAIL^A6ASFL^^2;0
 ;;^DD(A6AFIL,3.1,0)
 ;;=AREA CODE^NJ3,0^^3;1^K:+X'=X!(X>999)!(X<100)!(X?.E1"."1N.N) X
 ;;^DD(A6AFIL,3.1,3)
 ;;=Type a Number between 100 and 999, 0 Decimal Digits
 ;;^DD(A6AFIL,3.2,0)
 ;;=LOCAL NUMBER^F^^3;2^K:$L(X)>8!($L(X)<8)!'(X?3N1"-"4N) X
 ;;^DD(A6AFIL,3.2,3)
 ;;=Answer must be 8 characters in length.
 ;;^DD(A6AFIL,3.3,0)
 ;;=PHONE NUMBER^F^^3;3^K:$L(X)>15!($L(X)<1) X
 ;;^DD(A6AFIL,3.3,3)
 ;;=Answer must be 1-15 characters in length.
 ;;^DD(A6AFIL,3.4,0)
 ;;=OLD PHONE NUMBER^F^^3;4^K:$L(X)>15!($L(X)<1) X
 ;;^DD(A6AFIL,3.4,3)
 ;;=Answer must be 1-15 characters in length.
 ;;^DD(A6AFIL,4.1,0)
 ;;=DATE CREATED^D^^4;1^S %DT="ESTXR" D ^%DT S X=Y K:Y<1 X
 ;;^DD(A6ASFL,0)
 ;;=EMAIL SUB-FIELD^^1^2
 ;;^DD(A6ASFL,0,"NM","EMAIL")
 ;;=
 ;;^DD(A6ASFL,0,"UP")
 ;;=A6AFIL
 ;;^DD(A6ASFL,.01,0)
 ;;=EMAIL NAME^MF^^0;1^K:$L(X)>20!($L(X)<1) X
 ;;^DD(A6ASFL,.01,1,0)
 ;;=^.1
 ;;^DD(A6ASFL,.01,1,1,0)
 ;;=A6ASFL^B
 ;;^DD(A6ASFL,.01,1,1,1)
 ;;=S ^DIZ(A6AFIL,DA(1),2,"B",$E(X,1,30),DA)=""
 ;;^DD(A6ASFL,.01,1,1,2)
 ;;=K ^DIZ(A6AFIL,DA(1),2,"B",$E(X,1,30),DA)
 ;;^DD(A6ASFL,.01,3)
 ;;=Answer must be 1-20 characters in length.
 ;;^DD(A6ASFL,1,0)
 ;;=EMAIL DOMAIN^F^^0;2^K:$L(X)>20!($L(X)<1) X
 ;;^DD(A6ASFL,1,3)
 ;;=Answer must be 1-20 characters in length.

A6AKIT2^INT^1^60186,40400^
A6AKIT2 ;SFISC/MKO-DATA FOR ZZINDIVIDUAL FILE ;11:13 AM  13 Oct 2005
 ;;1.0;KEY AND INDEX TUTORIAL;Mar 1, 2001
DATA(A6AGL,A6ASFL) ;Set data
 N A6AGBL,X,Y,Z
 S A6AGBL=$$CREF^DILF(A6AGL)
 F I=1:2 S X=$T(ENTRY+I) Q:X=""  D
 . S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999)
 . F  Q:Y'["A6ASFL"  S Y=$P(Y,"A6ASFL")_A6ASFL_$P(Y,"A6ASFL",2,999)
 . S @X=Y
 N DA,DIC,DIK S DIK=A6AGL D IXALL^DIK
 Q
ENTRY ;
 ;;@A6AGBL@(1,0)
 ;;=FMPATIENT,ONE^000221111^2450520
 ;;@A6AGBL@(1,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(1,2,1,0)
 ;;=rc^aaa.bbb.com
 ;;@A6AGBL@(1,2,2,0)
 ;;=rose^xxx.yyy.com
 ;;@A6AGBL@(1,3)
 ;;=206^555-4112
 ;;@A6AGBL@(2,0)
 ;;=FMPATIENT,TWO^666443333^2320205
 ;;@A6AGBL@(2,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(2,2,1,0)
 ;;=jasmine.geiser^aaa.bbb.com
 ;;@A6AGBL@(2,2,2,0)
 ;;=jasmine^xxx.yyy.com
 ;;@A6AGBL@(2,3)
 ;;=206^555-8257
 ;;@A6AGBL@(3,0)
 ;;=FMPATIENT,THREE^666776666^2590714
 ;;@A6AGBL@(3,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(3,2,1,0)
 ;;=herb^abc.def.com
 ;;@A6AGBL@(3,2,2,0)
 ;;=hwaters^abc.def.com
 ;;@A6AGBL@(3,3)
 ;;=406^555-5834
 ;;@A6AGBL@(4,0)
 ;;=FMPATIENT,FOUR^666223333^2691123
 ;;@A6AGBL@(4,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(4,2,1,0)
 ;;=mlake^xxx.yyy.com
 ;;@A6AGBL@(4,2,2,0)
 ;;=marigold^aaa.bbb.com
 ;;@A6AGBL@(4,3)
 ;;=503^555-3612
 ;;@A6AGBL@(5,0)
 ;;=FMPATIENT,FIVE^666654321^2710227
 ;;@A6AGBL@(5,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(5,2,1,0)
 ;;=dill^abc.def.com
 ;;@A6AGBL@(5,2,2,0)
 ;;=dtide^xxx.yyy.com
 ;;@A6AGBL@(5,3)
 ;;=505^555-5939
 ;;@A6AGBL@(6,0)
 ;;=FMPATIENT,SIX^666889999^2550602
 ;;@A6AGBL@(6,2,0)
 ;;=^A6ASFL^1^1
 ;;@A6AGBL@(6,2,1,0)
 ;;=sagebrooks^aaa.bbb.com
 ;;@A6AGBL@(6,3)
 ;;=307^555-4680
 ;;@A6AGBL@(7,0)
 ;;=FMPATIENT,SEVEN^666678901^2480811
 ;;@A6AGBL@(7,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(7,2,1,0)
 ;;=hazel.frost^abc.def.com
 ;;@A6AGBL@(7,2,2,0)
 ;;=hazel^abc.def.com
 ;;@A6AGBL@(7,3)
 ;;=503^555-6874
 ;;@A6AGBL@(8,0)
 ;;=FMPATIENT,EIGHT^666891234^2730926
 ;;@A6AGBL@(8,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(8,2,1,0)
 ;;=saffron^aaa.bbb.com
 ;;@A6AGBL@(8,2,2,0)
 ;;=sripple^abc.def.com
 ;;@A6AGBL@(8,3)
 ;;=503^555-7555^^
 ;;@A6AGBL@(9,0)
 ;;=FMPATIENT,NINE^666345678^2191031
 ;;@A6AGBL@(9,2,0)
 ;;=^A6ASFL^1^1
 ;;@A6AGBL@(9,2,1,0)
 ;;=ginger^aaa.bbb.com
 ;;@A6AGBL@(9,3)
 ;;=208^555-8097
 ;;@A6AGBL@(10,0)
 ;;=FMPATIENT,TEN^666432123^2380409
 ;;@A6AGBL@(10,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(10,2,1,0)
 ;;=periwinkle^abc.def.com
 ;;@A6AGBL@(10,2,2,0)
 ;;=pwells^xxx.yyy.com
 ;;@A6AGBL@(10,3)
 ;;=415^555-5938
 ;;@A6AGBL@(11,0)
 ;;=FMPATIENT,ELEVEN^666765432^2700321
 ;;@A6AGBL@(11,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(11,2,1,0)
 ;;=chervil^xxx.yyy.com
 ;;@A6AGBL@(11,2,2,0)
 ;;=cpuddles^abc.def.com
 ;;@A6AGBL@(11,3)
 ;;=907^555-7584
 ;;@A6AGBL@(12,0)
 ;;=FMPATIENT,TWELVE^666996666^2470522
 ;;@A6AGBL@(12,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(12,2,1,0)
 ;;=basil^abc.def.com
 ;;@A6AGBL@(12,2,2,0)
 ;;=bsnow^xxx.yyy.com
 ;;@A6AGBL@(12,3)
 ;;=503^555-9573
 ;;@A6AGBL@(13,0)
 ;;=FMPATIENT,THIRTEEN^666567890^2450520
 ;;@A6AGBL@(13,2,0)
 ;;=^A6ASFL^2^2
 ;;@A6AGBL@(13,2,1,0)
 ;;=holly^abc.def.com
 ;;@A6AGBL@(13,2,2,0)
 ;;=hollyrivers^xxx.yyy.com
 ;;@A6AGBL@(13,3)
 ;;=509^555-7969