AG6P14 ;IHS/ASDST/GTH - AG 6 PATCH 14 ;
;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
;
; IHS/ASDST/GTH AG*6*14 09/27/2001
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(1) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(1) Q
;
I '(DUZ(0)["@") W:'$D(ZTQUEUED) !,"DUZ(0) DOES NOT CONTAIN AN '@'." D SORRY(1) Q
;
S X=$P(^VA(200,DUZ,0),U)
W !!,$$C^XBFUNC("Hello, "_$P(X,",",2)_" "_$P(X,","))
W !!,$$C^XBFUNC("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".")
;
S X=$$VERSION^XPDUTL("AG")
W !!,$$C^XBFUNC("Need AG v 6.0.....AG v "_X_" Present")
I X<6 D SORRY(1) Q
;
S X=$$VERSION^XPDUTL("DI")
W !,$$C^XBFUNC("Need at least FileMan 21.....FileMan "_X_" Present")
I X<21 D SORRY(1) Q
;
S X=$$VERSION^XPDUTL("XU")
W !,$$C^XBFUNC("Need at least Kernel 8.....Kernel "_X_" Present")
I X<8 D SORRY(1) Q
;
S X=$$VERSION^XPDUTL("AUT")
W !,$$C^XBFUNC("Need at least AUT 98.1.....AUT "_X_" Present")
I X<98.1,+X'=1.1 D SORRY(1) Q
;
S X=$$VERSION^XPDUTL("AUPN")
W !,$$C^XBFUNC("Need at least AUPN 99.1.....AUPN "_X_" Present")
I X<99.1 D SORRY(1) Q
;
NEW DA,DIC
S X="AG",DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","AG")) D Q
. W !!,*7,*7,$$C^XBFUNC("You Have More Than One Entry In The"),!,$$C^XBFUNC("PACKAGE File with an ""AG"" prefix.")
. W !,$$C^XBFUNC("One entry needs to be deleted.")
. W !,$$C^XBFUNC("FIX IT! Before Proceeding."),!!,*7,*7,*7
. D SORRY(1)
. I $$DIR^XBDIR("E")
.Q
W !,$$C^XBFUNC("No 'AG' dups in PACKAGE file")
;
I $G(XPDENV)=1 D
. ; The following line prevents the "Disable Options..." and "Move
. ; Routines..." questions from being asked during the install.
. S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
. D BMES^XPDUTL("Saving 7 AGTX* routines, just in case....")
. D BEFSAV
. D BMES^XPDUTL("Saving the configuration of option AGMENU...")
. D OPTSAV("AGMENU")
.Q
;
W !!,$$C^XBFUNC("ENVIRONMENT OK.")
;
NEW B
I $G(XPDA) S B=$O(^XTMP("XPDI",XPDA,"BLD",0))
I $G(B),$$DIR^XBDIR("Y","Do you want to see the notes","NO","Do you want to see the notes file for this patch","","",1) D
. S %=0
. F S %=$O(^XTMP("XPDI",XPDA,"BLD",B,1,%)) Q:'% W !,^(%,0) I '(%#20),'$$DIR^XBDIR("E","","","","","",1) Q
.Q
KILL B
;
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(1) Q
Q
;
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X,XPDQUIT("AG*6*14")=1
W:'$D(ZTQUEUED) *7,!,$$C^XBFUNC("Sorry...."),$$DIR^XBDIR("E","Press RETURN")
Q
;
PRE ;EP - From KIDS.
Q
D BMES^XPDUTL("Beginning pre-install routine (PRE^AG6P14).")
D BMES^XPDUTL("Pre-install routine is complete.")
Q
;
POST ;EP - From KIDS.
D BMES^XPDUTL("Beginning post-install routine (POST^AG6P14).")
D INDEXAI
;
D BMES^XPDUTL("Saving 7 AGTX* post-P14 routines, just in case....")
D AFTSAV^AGTXCONF
;
D BMES^XPDUTL("Q'ing Name check report...")
S ZTRTN="START^AGEDNAME",ZTIO="",ZTDESC=$P($P($T(+1^AGEDNAME),";",2)," ",3,99),ZTDTH=$H
D ^%ZTLOAD
I $D(ZTSK) D MES^XPDUTL("Que'd to task "_ZTSK_".") I 1
E D BMES^XPDUTL("Que of Name check report *FAILED*.")
;
D BMES^XPDUTL("Attaching ""AG REP NAME CHECK"" option to menu ""REGISTRATION REPORTS"".")
I $$ADD^XPDMENU("AGREPORTS","AG REP NAME CHECK","STD",25) D BMES^XPDUTL("....successfully atch'd....allocating Security Keys...") D I 1
. NEW AG,DA,DIC,DINUM
. S AG=0,AG("RPT")=$O(^DIC(19.1,"B","AGZREPORTS",0)),AG("STD")=$O(^DIC(19.1,"B","AGZNAMECHECK",0))
. Q:'AG("RPT")!'AG("STD")
. S DIC(0)="NMQ",DIC("P")="200.051PA"
. F S AG=$O(^XUSEC("AGZREPORTS",AG)) Q:'AG D
.. Q:$D(^VA(200,AG,51,AG("STD")))
.. S DIC="^VA(200,AG,51,",DA(1)=AG,(DINUM,X)=AG("STD")
.. D FILE^DICN
..Q
.Q
E D BMES^XPDUTL("....Attachment *FAILED*.")
;
D BMES^XPDUTL("Attaching ""AGTXALL"" option to the export menu ""AGTX"".")
I $$ADD^XPDMENU("AGTX","AGTXALL","ALL",10) D BMES^XPDUTL("....successfully atch'd."),BMES^XPDUTL("NOTE: Security key will *NOT* be allocated.") I 1
E D BMES^XPDUTL("....Attachment *FAILED*.")
;
D BMES^XPDUTL("Attaching ""AG TX CONFIG"" option to the export menu ""AGTX"".")
I $$ADD^XPDMENU("AGTX","AG TX CONFIG","CON",11) D BMES^XPDUTL("....successfully atch'd."),BMES^XPDUTL("NOTE: Security key will *NOT* be allocated.") I 1
E D BMES^XPDUTL("....Attachment *FAILED*.")
;
D BMES^XPDUTL("Restoring ""AGMENU"" option to PRE-install configuration...")
D OPTRES("AGMENU")
;
D BMES^XPDUTL("Delivering AG*6*14 install message to select users...")
D SAVE
NEW DIFROM
D MAIL^XBMAIL("AGZMENU,XUMGR-XUPROGMODE","MSG^AG6P14MS")
S X="AG6P14MS"
X ^%ZOSF("DEL")
;
D BMES^XPDUTL("Post-install routine is complete.")
Q
;
SAVE ; Save first few lines of install message into tmp global.
KILL ^TMP("AG6P14MS",$J)
S ^TMP("AG6P14MS",$J,1,0)="AG6P14MS ;IHS/ASDST/GTH - AG6P14 INSTALL MESSAGE ;"
S ^TMP("AG6P14MS",$J,2,0)=$T(+2)
S ^TMP("AG6P14MS",$J,3,0)="MSG ;;"
S ^TMP("AG6P14MS",$J,4,0)=" ;;AG V "_$P($T(+2),";",3)_" "_$P($T(+2),";",4)_", Patch "_$P($P($T(+2),";",5),"**",2)
S ^TMP("AG6P14MS",$J,5,0)=" ;; --- AG v 6, Patch 14, has been installed into this uci ---"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("AG6P14MS",$J,(%+5),0)=" ;;"_^(%,0)
NEW XCM,DIE,XCN
S X="AG6P14MS",DIE="^TMP(""AG6P14MS"",$J,",XCN=0
X ^%ZOSF("SAVE")
KILL ^TMP("AG6P14MS",$J)
Q
;
INDEXAI ; REINDEX AI XREF PREVIOUS COMMUNITY
;
; Thanks to Toni Jarland for the original routine. Aug 17 2001.
;
;This runs the AI X-Ref Re-Index of the Previous Communty Multiple
;$Order through each AUPNPAT Global Entry & Re-Index AI X-Ref
;The AI X-Ref calls Routine AUPNPCTR which $O thru the Previous
;Community Multiple & resets the Last Previous Community Entry
;to fields #1117 Current Community Mulitple & #1118 Current Community
;Text Value. This will clean up missing Community Pointers used
;in the Patient Registration Re-export
;
I $P($T(+2^AUPNPCTR),";",5)'="**6**" D Q
. D BMES^XPDUTL("AUPN PATCH 6 IS NOT INSTALLED.")
. D BMES^XPDUTL("THE AI X-REF RE-FIRE WILL BE IN VAIN.")
. D BMES^XPDUTL("INSTALL AUPN 99.1 PATCH 6 AND RUN INDEXAI^AG6P14.")
.Q
NEW AGB,AGE
S AGB=$$NOW^XLFDT
D BMES^XPDUTL("Begin Re-Indexing AI Cross Reference of PATIENT File, "_$$FMTE^XLFDT(AGB))
W:'$D(ZTQUEUED) !,"Estimated % complete:",!
NEW AGP3,DA,DIK
S DA(1)=0,DIK(1)=".03^AI",AGP3=$P(^AUPNPAT(0),U,3)
F S DA(1)=$O(^AUPNPAT(DA(1))) Q:'DA(1) D
. S DIK="^AUPNPAT("_DA(1)_",51,"
. D ENALL^DIK
. I '(DA(1)#100),'$D(ZTQUEUED) W " | ",$J(DA(1)/AGP3*100,0,0),"%"
.Q
;
S AGE=$$NOW^XLFDT
D BMES^XPDUTL("End of Re-Indexing AI Cross Reference of PATIENT File, "_$$FMTE^XLFDT(AGE))
D BMES^XPDUTL($$FMDIFF^XLFDT(AGE,AGB,2)_" seconds")
Q
;
BEFSAV ;this is the same s/r as in AGTXCONF.
NEW AG,AGM,XCN,XCNP,DIE,DIF
F AG=1:1:7 D
. D KT
. S X=$P($T(BEF+AG),";",3),(XCN,XCNP)=0,(DIE,DIF)="^TMP(""AGTXCONF"",$J,"
. S AGM="Loading '"_X_"'..."
. X ^%ZOSF("LOAD")
. S X=$P($T(BEF+AG),";",4)
. X ^%ZOSF("TEST")
. I D MES^XPDUTL(AGM_"NOT SAVED AS '"_X_"'. '"_X_"' ALREADY EXISTS.") Q
. X ^%ZOSF("SAVE")
. D MES^XPDUTL(AGM_"Saved as '"_X_"'.")
.Q
D KT
Q
;
KT KILL ^TMP("AGTXCONF",$J)
Q
;
BEF ; These are the "before p14" routines.
;;AGTX1;AGTXX1
;;AGTX2;AGTXX2
;;AGTX3;AGTXX3
;;AGTX4;AGTXX4
;;AGTX5;AGTXX5
;;AGTXST;AGTXX6
;;AGTXTAPE;AGTXX7
;
OPTSAV(AGM) ;
I $D(^XTMP("AG6P14",6.14,"OPTSAV",AGM)) D BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' has previously been saved.") Q
I '$D(^XTMP("AG6P14")) S ^XTMP("AG6P14",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"AG6P14 - SAVE OPTION CONFIGURATIONS."
NEW I,A
S I=$O(^DIC(19,"B",AGM,0))
I 'I D BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' not found in OPTION file.") Q
S A=0
F S A=$O(^DIC(19,I,10,A)) Q:'A S ^XTMP("AG6P14",6.14,"OPTSAV",AGM,A)=$P(^DIC(19,+^DIC(19,I,10,A,0),0),U,1)_U_$P(^DIC(19,I,10,A,0),U,2,3)
Q
;
OPTRES(AGM) ;
NEW AG,AGI
I '$D(^XTMP("AG6P14",6.14,"OPTSAV",AGM)) D BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.") Q
S AG=0
F S AG=$O(^XTMP("AG6P14",6.14,"OPTSAV",AGM,AG)) Q:'AG S AGI=^(AG) I '$$ADD^XPDMENU(AGM,$P(AGI,U,1),$P(AGI,U,2),$P(AGI,U,3)) D BMES^XPDUTL("....FAILED to re-atch "_$P(AGI,U,1)_" to "_AGM_".")
Q
;
AG6P14 ;IHS/ASDST/GTH - AG 6 PATCH 14 ;
+1 ;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
+2 ;
+3 ; IHS/ASDST/GTH AG*6*14 09/27/2001
+4 ;
+5 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(1)
QUIT
+6 ;
+7 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(1)
QUIT
+8 ;
+9 IF '(DUZ(0)["@")
IF '$DATA(ZTQUEUED)
WRITE !,"DUZ(0) DOES NOT CONTAIN AN '@'."
DO SORRY(1)
QUIT
+10 ;
+11 SET X=$PIECE(^VA(200,DUZ,0),U)
+12 WRITE !!,$$C^XBFUNC("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","))
+13 WRITE !!,$$C^XBFUNC("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".")
+14 ;
+15 SET X=$$VERSION^XPDUTL("AG")
+16 WRITE !!,$$C^XBFUNC("Need AG v 6.0.....AG v "_X_" Present")
+17 IF X<6
DO SORRY(1)
QUIT
+18 ;
+19 SET X=$$VERSION^XPDUTL("DI")
+20 WRITE !,$$C^XBFUNC("Need at least FileMan 21.....FileMan "_X_" Present")
+21 IF X<21
DO SORRY(1)
QUIT
+22 ;
+23 SET X=$$VERSION^XPDUTL("XU")
+24 WRITE !,$$C^XBFUNC("Need at least Kernel 8.....Kernel "_X_" Present")
+25 IF X<8
DO SORRY(1)
QUIT
+26 ;
+27 SET X=$$VERSION^XPDUTL("AUT")
+28 WRITE !,$$C^XBFUNC("Need at least AUT 98.1.....AUT "_X_" Present")
+29 IF X<98.1
IF +X'=1.1
DO SORRY(1)
QUIT
+30 ;
+31 SET X=$$VERSION^XPDUTL("AUPN")
+32 WRITE !,$$C^XBFUNC("Need at least AUPN 99.1.....AUPN "_X_" Present")
+33 IF X<99.1
DO SORRY(1)
QUIT
+34 ;
+35 NEW DA,DIC
+36 SET X="AG"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+37 DO IX^DIC
+38 IF Y<0
IF $DATA(^DIC(9.4,"C","AG"))
Begin DoDot:1
+39 WRITE !!,*7,*7,$$C^XBFUNC("You Have More Than One Entry In The"),!,$$C^XBFUNC("PACKAGE File with an ""AG"" prefix.")
+40 WRITE !,$$C^XBFUNC("One entry needs to be deleted.")
+41 WRITE !,$$C^XBFUNC("FIX IT! Before Proceeding."),!!,*7,*7,*7
+42 DO SORRY(1)
+43 IF $$DIR^XBDIR("E")
+44 QUIT
End DoDot:1
QUIT
+45 WRITE !,$$C^XBFUNC("No 'AG' dups in PACKAGE file")
+46 ;
+47 IF $GET(XPDENV)=1
Begin DoDot:1
+48 ; The following line prevents the "Disable Options..." and "Move
+49 ; Routines..." questions from being asked during the install.
+50 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+51 DO BMES^XPDUTL("Saving 7 AGTX* routines, just in case....")
+52 DO BEFSAV
+53 DO BMES^XPDUTL("Saving the configuration of option AGMENU...")
+54 DO OPTSAV("AGMENU")
+55 QUIT
End DoDot:1
+56 ;
+57 WRITE !!,$$C^XBFUNC("ENVIRONMENT OK.")
+58 ;
+59 NEW B
+60 IF $GET(XPDA)
SET B=$ORDER(^XTMP("XPDI",XPDA,"BLD",0))
+61 IF $GET(B)
IF $$DIR^XBDIR("Y","Do you want to see the notes","NO","Do you want to see the notes file for this patch","","",1)
Begin DoDot:1
+62 SET %=0
+63 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",B,1,%))
IF '%
QUIT
WRITE !,^(%,0)
IF '(%#20)
IF '$$DIR^XBDIR("E","","","","","",1)
QUIT
+64 QUIT
End DoDot:1
+65 KILL B
+66 ;
+67 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(1)
QUIT
+68 QUIT
+69 ;
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
SET XPDQUIT("AG*6*14")=1
+3 IF '$DATA(ZTQUEUED)
WRITE *7,!,$$C^XBFUNC("Sorry...."),$$DIR^XBDIR("E","Press RETURN")
+4 QUIT
+5 ;
PRE ;EP - From KIDS.
+1 QUIT
+2 DO BMES^XPDUTL("Beginning pre-install routine (PRE^AG6P14).")
+3 DO BMES^XPDUTL("Pre-install routine is complete.")
+4 QUIT
+5 ;
POST ;EP - From KIDS.
+1 DO BMES^XPDUTL("Beginning post-install routine (POST^AG6P14).")
+2 DO INDEXAI
+3 ;
+4 DO BMES^XPDUTL("Saving 7 AGTX* post-P14 routines, just in case....")
+5 DO AFTSAV^AGTXCONF
+6 ;
+7 DO BMES^XPDUTL("Q'ing Name check report...")
+8 SET ZTRTN="START^AGEDNAME"
SET ZTIO=""
SET ZTDESC=$PIECE($PIECE($TEXT(+1^AGEDNAME),";",2)," ",3,99)
SET ZTDTH=$HOROLOG
+9 DO ^%ZTLOAD
+10 IF $DATA(ZTSK)
DO MES^XPDUTL("Que'd to task "_ZTSK_".")
IF 1
+11 IF '$TEST
DO BMES^XPDUTL("Que of Name check report *FAILED*.")
+12 ;
+13 DO BMES^XPDUTL("Attaching ""AG REP NAME CHECK"" option to menu ""REGISTRATION REPORTS"".")
+14 IF $$ADD^XPDMENU("AGREPORTS","AG REP NAME CHECK","STD",25)
DO BMES^XPDUTL("....successfully atch'd....allocating Security Keys...")
Begin DoDot:1
+15 NEW AG,DA,DIC,DINUM
+16 SET AG=0
SET AG("RPT")=$ORDER(^DIC(19.1,"B","AGZREPORTS",0))
SET AG("STD")=$ORDER(^DIC(19.1,"B","AGZNAMECHECK",0))
+17 IF 'AG("RPT")!'AG("STD")
QUIT
+18 SET DIC(0)="NMQ"
SET DIC("P")="200.051PA"
+19 FOR
SET AG=$ORDER(^XUSEC("AGZREPORTS",AG))
IF 'AG
QUIT
Begin DoDot:2
+20 IF $DATA(^VA(200,AG,51,AG("STD")))
QUIT
+21 SET DIC="^VA(200,AG,51,"
SET DA(1)=AG
SET (DINUM,X)=AG("STD")
+22 DO FILE^DICN
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
IF 1
+25 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+26 ;
+27 DO BMES^XPDUTL("Attaching ""AGTXALL"" option to the export menu ""AGTX"".")
+28 IF $$ADD^XPDMENU("AGTX","AGTXALL","ALL",10)
DO BMES^XPDUTL("....successfully atch'd.")
DO BMES^XPDUTL("NOTE: Security key will *NOT* be allocated.")
IF 1
+29 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+30 ;
+31 DO BMES^XPDUTL("Attaching ""AG TX CONFIG"" option to the export menu ""AGTX"".")
+32 IF $$ADD^XPDMENU("AGTX","AG TX CONFIG","CON",11)
DO BMES^XPDUTL("....successfully atch'd.")
DO BMES^XPDUTL("NOTE: Security key will *NOT* be allocated.")
IF 1
+33 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+34 ;
+35 DO BMES^XPDUTL("Restoring ""AGMENU"" option to PRE-install configuration...")
+36 DO OPTRES("AGMENU")
+37 ;
+38 DO BMES^XPDUTL("Delivering AG*6*14 install message to select users...")
+39 DO SAVE
+40 NEW DIFROM
+41 DO MAIL^XBMAIL("AGZMENU,XUMGR-XUPROGMODE","MSG^AG6P14MS")
+42 SET X="AG6P14MS"
+43 XECUTE ^%ZOSF("DEL")
+44 ;
+45 DO BMES^XPDUTL("Post-install routine is complete.")
+46 QUIT
+47 ;
SAVE ; Save first few lines of install message into tmp global.
+1 KILL ^TMP("AG6P14MS",$JOB)
+2 SET ^TMP("AG6P14MS",$JOB,1,0)="AG6P14MS ;IHS/ASDST/GTH - AG6P14 INSTALL MESSAGE ;"
+3 SET ^TMP("AG6P14MS",$JOB,2,0)=$TEXT(+2)
+4 SET ^TMP("AG6P14MS",$JOB,3,0)="MSG ;;"
+5 SET ^TMP("AG6P14MS",$JOB,4,0)=" ;;AG V "_$PIECE($TEXT(+2),";",3)_" "_$PIECE($TEXT(+2),";",4)_", Patch "_$PIECE($PIECE($TEXT(+2),";",5),"**",2)
+6 SET ^TMP("AG6P14MS",$JOB,5,0)=" ;; --- AG v 6, Patch 14, has been installed into this uci ---"
+7 SET %=0
+8 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
SET ^TMP("AG6P14MS",$JOB,(%+5),0)=" ;;"_^(%,0)
+9 NEW XCM,DIE,XCN
+10 SET X="AG6P14MS"
SET DIE="^TMP(""AG6P14MS"",$J,"
SET XCN=0
+11 XECUTE ^%ZOSF("SAVE")
+12 KILL ^TMP("AG6P14MS",$JOB)
+13 QUIT
+14 ;
INDEXAI ; REINDEX AI XREF PREVIOUS COMMUNITY
+1 ;
+2 ; Thanks to Toni Jarland for the original routine. Aug 17 2001.
+3 ;
+4 ;This runs the AI X-Ref Re-Index of the Previous Communty Multiple
+5 ;$Order through each AUPNPAT Global Entry & Re-Index AI X-Ref
+6 ;The AI X-Ref calls Routine AUPNPCTR which $O thru the Previous
+7 ;Community Multiple & resets the Last Previous Community Entry
+8 ;to fields #1117 Current Community Mulitple & #1118 Current Community
+9 ;Text Value. This will clean up missing Community Pointers used
+10 ;in the Patient Registration Re-export
+11 ;
+12 IF $PIECE($TEXT(+2^AUPNPCTR),";",5)'="**6**"
Begin DoDot:1
+13 DO BMES^XPDUTL("AUPN PATCH 6 IS NOT INSTALLED.")
+14 DO BMES^XPDUTL("THE AI X-REF RE-FIRE WILL BE IN VAIN.")
+15 DO BMES^XPDUTL("INSTALL AUPN 99.1 PATCH 6 AND RUN INDEXAI^AG6P14.")
+16 QUIT
End DoDot:1
QUIT
+17 NEW AGB,AGE
+18 SET AGB=$$NOW^XLFDT
+19 DO BMES^XPDUTL("Begin Re-Indexing AI Cross Reference of PATIENT File, "_$$FMTE^XLFDT(AGB))
+20 IF '$DATA(ZTQUEUED)
WRITE !,"Estimated % complete:",!
+21 NEW AGP3,DA,DIK
+22 SET DA(1)=0
SET DIK(1)=".03^AI"
SET AGP3=$PIECE(^AUPNPAT(0),U,3)
+23 FOR
SET DA(1)=$ORDER(^AUPNPAT(DA(1)))
IF 'DA(1)
QUIT
Begin DoDot:1
+24 SET DIK="^AUPNPAT("_DA(1)_",51,"
+25 DO ENALL^DIK
+26 IF '(DA(1)#100)
IF '$DATA(ZTQUEUED)
WRITE " | ",$JUSTIFY(DA(1)/AGP3*100,0,0),"%"
+27 QUIT
End DoDot:1
+28 ;
+29 SET AGE=$$NOW^XLFDT
+30 DO BMES^XPDUTL("End of Re-Indexing AI Cross Reference of PATIENT File, "_$$FMTE^XLFDT(AGE))
+31 DO BMES^XPDUTL($$FMDIFF^XLFDT(AGE,AGB,2)_" seconds")
+32 QUIT
+33 ;
BEFSAV ;this is the same s/r as in AGTXCONF.
+1 NEW AG,AGM,XCN,XCNP,DIE,DIF
+2 FOR AG=1:1:7
Begin DoDot:1
+3 DO KT
+4 SET X=$PIECE($TEXT(BEF+AG),";",3)
SET (XCN,XCNP)=0
SET (DIE,DIF)="^TMP(""AGTXCONF"",$J,"
+5 SET AGM="Loading '"_X_"'..."
+6 XECUTE ^%ZOSF("LOAD")
+7 SET X=$PIECE($TEXT(BEF+AG),";",4)
+8 XECUTE ^%ZOSF("TEST")
+9 IF $TEST
DO MES^XPDUTL(AGM_"NOT SAVED AS '"_X_"'. '"_X_"' ALREADY EXISTS.")
QUIT
+10 XECUTE ^%ZOSF("SAVE")
+11 DO MES^XPDUTL(AGM_"Saved as '"_X_"'.")
+12 QUIT
End DoDot:1
+13 DO KT
+14 QUIT
+15 ;
KT KILL ^TMP("AGTXCONF",$JOB)
+1 QUIT
+2 ;
BEF ; These are the "before p14" routines.
+1 ;;AGTX1;AGTXX1
+2 ;;AGTX2;AGTXX2
+3 ;;AGTX3;AGTXX3
+4 ;;AGTX4;AGTXX4
+5 ;;AGTX5;AGTXX5
+6 ;;AGTXST;AGTXX6
+7 ;;AGTXTAPE;AGTXX7
+8 ;
OPTSAV(AGM) ;
+1 IF $DATA(^XTMP("AG6P14",6.14,"OPTSAV",AGM))
DO BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' has previously been saved.")
QUIT
+2 IF '$DATA(^XTMP("AG6P14"))
SET ^XTMP("AG6P14",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"AG6P14 - SAVE OPTION CONFIGURATIONS."
+3 NEW I,A
+4 SET I=$ORDER(^DIC(19,"B",AGM,0))
+5 IF 'I
DO BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' not found in OPTION file.")
QUIT
+6 SET A=0
+7 FOR
SET A=$ORDER(^DIC(19,I,10,A))
IF 'A
QUIT
SET ^XTMP("AG6P14",6.14,"OPTSAV",AGM,A)=$PIECE(^DIC(19,+^DIC(19,I,10,A,0),0),U,1)_U_$PIECE(^DIC(19,I,10,A,0),U,2,3)
+8 QUIT
+9 ;
OPTRES(AGM) ;
+1 NEW AG,AGI
+2 IF '$DATA(^XTMP("AG6P14",6.14,"OPTSAV",AGM))
DO BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.")
QUIT
+3 SET AG=0
+4 FOR
SET AG=$ORDER(^XTMP("AG6P14",6.14,"OPTSAV",AGM,AG))
IF 'AG
QUIT
SET AGI=^(AG)
IF '$$ADD^XPDMENU(AGM,$PIECE(AGI,U,1),$PIECE(AGI,U,2),$PIECE(AGI,U,3))
DO BMES^XPDUTL("....FAILED to re-atch "_$PIECE(AGI,U,1)_" to "_AGM_".")
+5 QUIT
+6 ;
