AG6P15 ;IHS/ASDST/GTH - AG 6 PATCH 15 ;
;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
;
; IHS/ASDST/GTH AG*6*15 12/10/2001
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) 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(2) Q
;
S X=$$VERSION^XPDUTL("DI")
W !,$$C^XBFUNC("Need at least FileMan 21.....FileMan "_X_" Present")
I X<21 D SORRY(2) Q
;
S X=$$VERSION^XPDUTL("XU")
W !,$$C^XBFUNC("Need at least Kernel 8.....Kernel "_X_" Present")
I X<8 D SORRY(2) 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(2) Q
;
S X=$$VERSION^XPDUTL("AUPN")
W !,$$C^XBFUNC("Need at least AUPN 99.1.....AUPN "_X_" Present")
I X<99.1 D SORRY(2) 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(2)
. 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
. I '$$P14 D BMES^XPDUTL("Saving 7 AGTX* routines, just in case...."),BEFSAV
. D BMES^XPDUTL("Saving the configuration of option AGMENU...")
. D OPTSAV("AGMENU")
.Q
;
W !!,$$C^XBFUNC("ENVIRONMENT OK.")
;
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
Q
;
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
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^AG6P15).")
D BMES^XPDUTL("Pre-install routine is complete.")
Q
;
POST ;EP - From KIDS.
D BMES^XPDUTL("Beginning post-install routine (POST^AG6P15).")
;
I '$$P14 D IP14
;
D BMES^XPDUTL("Restoring ""AGMENU"" option to PRE-install configuration...")
D OPTRES("AGMENU")
;
D P4
;
D BMES^XPDUTL("Attaching ""AG TM ELIGIBILITY"" option to the table maintenance menu ""TM"".")
I $$ADD^XPDMENU("AG TM MENU","AG TM ELIGIBILITY","ELUP",10) D BMES^XPDUTL("....successfully atch'd.") I 1
E D BMES^XPDUTL("....Attachment *FAILED*.")
;
D BMES^XPDUTL("Attaching ""AG3PSUM"" option to the the Third Party Billing Reports ""THR"".")
I $$ADD^XPDMENU("AGBILL","AG3PSUM","AGSM",4) D BMES^XPDUTL("....successfully atch'd.") I 1
E D BMES^XPDUTL("....Attachment *FAILED*.")
;
I $$VAL^XBDIQ1(9999999.39,1,.15)'="YES" D
. NEW AG
. S AG=0
. F S AG=$O(^ABMDCLM(AG)) Q:'AG I $$FMDIFF^XLFDT(DT,$O(^ABMDCLM(AG,"AC",9999999),-1),1)<180 D Q
.. NEW DA,DIE,DR
.. S DIE=9999999.39,DA=1,DR=".15///Y"
.. D ^DIE
.. I '$D(Y) D Q
... D BMES^XPDUTL("The 'THIRD-PARTY BILLING PRESENT' field in RPMS SITE had been changed to 'YES',")
... D MES^XPDUTL("based on 3PB editing activity in the last 6 months."),MES^XPDUTL("'YES' ensures setting of the 'ABILL' x-ref in the VISIT file.")
...Q
.. D BMES^XPDUTL("** ERROR: EDIT OF .15 IN RPMS SITE FILE FAILED.")
.. Q
.Q
;
D BMES^XPDUTL("Delivering AG*6*15 install message to select users...")
D MAIL
;
D BMES^XPDUTL("Post-install routine is complete.")
Q
;
MAIL ; Send install mail message.
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("AG6P15MS",$J)
S ^TMP("AG6P15MS",$J,1)=" --- AG v 6, Patch 15, has been installed into this uci ---"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("AG6P15MS",$J,(%+1))=" "_^(%,0)
S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AG6P15MS"",$J,",XMY(1)="",XMY(DUZ)=""
F %="AGZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("AG6P15MS",$J)
Q
;
SINGLE(K) ; Get holders of a single key K.
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
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^AG6P15.")
.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 p15" routines.
;;AGTX1;AGTXX1
;;AGTX2;AGTXX2
;;AGTX3;AGTXX3
;;AGTX4;AGTXX4
;;AGTX5;AGTXX5
;;AGTXST;AGTXX6
;;AGTXTAPE;AGTXX7
;
OPTSAV(AGM) ;
I $D(^XTMP("AG6P15",6.15,"OPTSAV",AGM)) D BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' has previously been saved.") Q
I '$D(^XTMP("AG6P15")) S ^XTMP("AG6P15",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"AG6P15 - 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("AG6P15",6.15,"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("AG6P15",6.15,"OPTSAV",AGM)) D BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.") Q
S AG=0
F S AG=$O(^XTMP("AG6P15",6.15,"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
;
IP14 ; Items from patch 14.
D BMES^XPDUTL("Patch 14 was not installed. Performing P14 items...")
;
D INDEXAI
;
D BMES^XPDUTL("Saving 7 AGTX* post-P15 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*.")
;
Q
;
P14() ; Determine if P14 was installed.
;;^DIC(9.4,D0,22,D1,PAH,D2,0)=
;;(#.01) PATCH APPLICATION HISTORY [1F] ^ (#.02)DATE APPLIED [2D] ^ (#.03) APPLIED BY [3P] ^
NEW DIC,X,Y
S X="IHS PATIENT REGISTRATION"
S DIC="^DIC(9.4,",DIC(0)="FM"
D ^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",22,",X="6.0"
D ^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",""PAH"",",X=14
D ^DIC
Q $S(Y<1:0,1:1)
;
;
P4 ; -- Update AGMENU exit action to include call to HL7 routine
;;D ^AGHL7,PHDR^AG,KILL^AG I $D(AGSADUZ2) S DUZ(2)=AGSADUZ2 K AGSADUZ2
;
NEW DA,DIE,DR
S DA=""
F S DA=$O(^DIC(19,"B","AGMENU",DA)) Q:DA="" D
. Q:^DIC(19,DA,15)=$P($T(P4+1),";",3)
. S DIE="^DIC(19,",DR="15///"_$P($T(P4+1),";",3)
. D ^DIE
.Q
Q
;
AG6P15 ;IHS/ASDST/GTH - AG 6 PATCH 15 ;
+1 ;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
+2 ;
+3 ; IHS/ASDST/GTH AG*6*15 12/10/2001
+4 ;
+5 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+6 ;
+7 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+8 ;
+9 SET X=$PIECE(^VA(200,DUZ,0),U)
+10 WRITE !!,$$C^XBFUNC("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","))
+11 WRITE !!,$$C^XBFUNC("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".")
+12 ;
+13 SET X=$$VERSION^XPDUTL("AG")
+14 WRITE !!,$$C^XBFUNC("Need AG v 6.0.....AG v "_X_" Present")
+15 IF X<6
DO SORRY(2)
QUIT
+16 ;
+17 SET X=$$VERSION^XPDUTL("DI")
+18 WRITE !,$$C^XBFUNC("Need at least FileMan 21.....FileMan "_X_" Present")
+19 IF X<21
DO SORRY(2)
QUIT
+20 ;
+21 SET X=$$VERSION^XPDUTL("XU")
+22 WRITE !,$$C^XBFUNC("Need at least Kernel 8.....Kernel "_X_" Present")
+23 IF X<8
DO SORRY(2)
QUIT
+24 ;
+25 SET X=$$VERSION^XPDUTL("AUT")
+26 WRITE !,$$C^XBFUNC("Need at least AUT 98.1.....AUT "_X_" Present")
+27 IF X<98.1
IF +X'=1.1
DO SORRY(2)
QUIT
+28 ;
+29 SET X=$$VERSION^XPDUTL("AUPN")
+30 WRITE !,$$C^XBFUNC("Need at least AUPN 99.1.....AUPN "_X_" Present")
+31 IF X<99.1
DO SORRY(2)
QUIT
+32 ;
+33 NEW DA,DIC
+34 SET X="AG"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+35 DO IX^DIC
+36 IF Y<0
IF $DATA(^DIC(9.4,"C","AG"))
Begin DoDot:1
+37 WRITE !!,*7,*7,$$C^XBFUNC("You Have More Than One Entry In The"),!,$$C^XBFUNC("PACKAGE File with an ""AG"" prefix.")
+38 WRITE !,$$C^XBFUNC("One entry needs to be deleted.")
+39 WRITE !,$$C^XBFUNC("FIX IT! Before Proceeding."),!!,*7,*7,*7
+40 DO SORRY(2)
+41 IF $$DIR^XBDIR("E")
+42 QUIT
End DoDot:1
QUIT
+43 WRITE !,$$C^XBFUNC("No 'AG' dups in PACKAGE file")
+44 ;
+45 IF $GET(XPDENV)=1
Begin DoDot:1
+46 ; The following line prevents the "Disable Options..." and "Move
+47 ; Routines..." questions from being asked during the install.
+48 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+49 IF '$$P14
DO BMES^XPDUTL("Saving 7 AGTX* routines, just in case....")
DO BEFSAV
+50 DO BMES^XPDUTL("Saving the configuration of option AGMENU...")
+51 DO OPTSAV("AGMENU")
+52 QUIT
End DoDot:1
+53 ;
+54 WRITE !!,$$C^XBFUNC("ENVIRONMENT OK.")
+55 ;
+56 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
QUIT
+57 QUIT
+58 ;
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+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^AG6P15).")
+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^AG6P15).")
+2 ;
+3 IF '$$P14
DO IP14
+4 ;
+5 DO BMES^XPDUTL("Restoring ""AGMENU"" option to PRE-install configuration...")
+6 DO OPTRES("AGMENU")
+7 ;
+8 DO P4
+9 ;
+10 DO BMES^XPDUTL("Attaching ""AG TM ELIGIBILITY"" option to the table maintenance menu ""TM"".")
+11 IF $$ADD^XPDMENU("AG TM MENU","AG TM ELIGIBILITY","ELUP",10)
DO BMES^XPDUTL("....successfully atch'd.")
IF 1
+12 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+13 ;
+14 DO BMES^XPDUTL("Attaching ""AG3PSUM"" option to the the Third Party Billing Reports ""THR"".")
+15 IF $$ADD^XPDMENU("AGBILL","AG3PSUM","AGSM",4)
DO BMES^XPDUTL("....successfully atch'd.")
IF 1
+16 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+17 ;
+18 IF $$VAL^XBDIQ1(9999999.39,1,.15)'="YES"
Begin DoDot:1
+19 NEW AG
+20 SET AG=0
+21 FOR
SET AG=$ORDER(^ABMDCLM(AG))
IF 'AG
QUIT
IF $$FMDIFF^XLFDT(DT,$ORDER(^ABMDCLM(AG,"AC",9999999),-1),1)<180
Begin DoDot:2
+22 NEW DA,DIE,DR
+23 SET DIE=9999999.39
SET DA=1
SET DR=".15///Y"
+24 DO ^DIE
+25 IF '$DATA(Y)
Begin DoDot:3
+26 DO BMES^XPDUTL("The 'THIRD-PARTY BILLING PRESENT' field in RPMS SITE had been changed to 'YES',")
+27 DO MES^XPDUTL("based on 3PB editing activity in the last 6 months.")
DO MES^XPDUTL("'YES' ensures setting of the 'ABILL' x-ref in the VISIT file.")
+28 QUIT
End DoDot:3
QUIT
+29 DO BMES^XPDUTL("** ERROR: EDIT OF .15 IN RPMS SITE FILE FAILED.")
+30 QUIT
End DoDot:2
QUIT
+31 QUIT
End DoDot:1
+32 ;
+33 DO BMES^XPDUTL("Delivering AG*6*15 install message to select users...")
+34 DO MAIL
+35 ;
+36 DO BMES^XPDUTL("Post-install routine is complete.")
+37 QUIT
+38 ;
MAIL ; Send install mail message.
+1 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+2 KILL ^TMP("AG6P15MS",$JOB)
+3 SET ^TMP("AG6P15MS",$JOB,1)=" --- AG v 6, Patch 15, has been installed into this uci ---"
+4 SET %=0
+5 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
SET ^TMP("AG6P15MS",$JOB,(%+1))=" "_^(%,0)
+6 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",4,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AG6P15MS"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+7 FOR %="AGZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+8 DO ^XMD
+9 KILL ^TMP("AG6P15MS",$JOB)
+10 QUIT
+11 ;
SINGLE(K) ; Get holders of a single key K.
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
+6 ;
+7 ;
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^AG6P15.")
+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 p15" 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("AG6P15",6.15,"OPTSAV",AGM))
DO BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' has previously been saved.")
QUIT
+2 IF '$DATA(^XTMP("AG6P15"))
SET ^XTMP("AG6P15",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"AG6P15 - 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("AG6P15",6.15,"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("AG6P15",6.15,"OPTSAV",AGM))
DO BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.")
QUIT
+3 SET AG=0
+4 FOR
SET AG=$ORDER(^XTMP("AG6P15",6.15,"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 ;
IP14 ; Items from patch 14.
+1 DO BMES^XPDUTL("Patch 14 was not installed. Performing P14 items...")
+2 ;
+3 DO INDEXAI
+4 ;
+5 DO BMES^XPDUTL("Saving 7 AGTX* post-P15 routines, just in case....")
+6 DO AFTSAV^AGTXCONF
+7 ;
+8 DO BMES^XPDUTL("Q'ing Name check report...")
+9 SET ZTRTN="START^AGEDNAME"
SET ZTIO=""
SET ZTDESC=$PIECE($PIECE($TEXT(+1^AGEDNAME),";",2)," ",3,99)
SET ZTDTH=$HOROLOG
+10 DO ^%ZTLOAD
+11 IF $DATA(ZTSK)
DO MES^XPDUTL("Que'd to task "_ZTSK_".")
IF 1
+12 IF '$TEST
DO BMES^XPDUTL("Que of Name check report *FAILED*.")
+13 ;
+14 DO BMES^XPDUTL("Attaching ""AG REP NAME CHECK"" option to menu ""REGISTRATION REPORTS"".")
+15 IF $$ADD^XPDMENU("AGREPORTS","AG REP NAME CHECK","STD",25)
DO BMES^XPDUTL("....successfully atch'd....allocating Security Keys...")
Begin DoDot:1
+16 NEW AG,DA,DIC,DINUM
+17 SET AG=0
SET AG("RPT")=$ORDER(^DIC(19.1,"B","AGZREPORTS",0))
SET AG("STD")=$ORDER(^DIC(19.1,"B","AGZNAMECHECK",0))
+18 IF 'AG("RPT")!'AG("STD")
QUIT
+19 SET DIC(0)="NMQ"
SET DIC("P")="200.051PA"
+20 FOR
SET AG=$ORDER(^XUSEC("AGZREPORTS",AG))
IF 'AG
QUIT
Begin DoDot:2
+21 IF $DATA(^VA(200,AG,51,AG("STD")))
QUIT
+22 SET DIC="^VA(200,AG,51,"
SET DA(1)=AG
SET (DINUM,X)=AG("STD")
+23 DO FILE^DICN
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
IF 1
+26 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+27 ;
+28 DO BMES^XPDUTL("Attaching ""AGTXALL"" option to the export menu ""AGTX"".")
+29 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
+30 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+31 ;
+32 DO BMES^XPDUTL("Attaching ""AG TX CONFIG"" option to the export menu ""AGTX"".")
+33 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
+34 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+35 ;
+36 QUIT
+37 ;
P14() ; Determine if P14 was installed.
+1 ;;^DIC(9.4,D0,22,D1,PAH,D2,0)=
+2 ;;(#.01) PATCH APPLICATION HISTORY [1F] ^ (#.02)DATE APPLIED [2D] ^ (#.03) APPLIED BY [3P] ^
+3 NEW DIC,X,Y
+4 SET X="IHS PATIENT REGISTRATION"
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
+6 DO ^DIC
+7 IF Y<1
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X="6.0"
+9 DO ^DIC
+10 IF Y<1
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=14
+12 DO ^DIC
+13 QUIT $SELECT(Y<1:0,1:1)
+14 ;
+15 ;
P4 ; -- Update AGMENU exit action to include call to HL7 routine
+1 ;;D ^AGHL7,PHDR^AG,KILL^AG I $D(AGSADUZ2) S DUZ(2)=AGSADUZ2 K AGSADUZ2
+2 ;
+3 NEW DA,DIE,DR
+4 SET DA=""
+5 FOR
SET DA=$ORDER(^DIC(19,"B","AGMENU",DA))
IF DA=""
QUIT
Begin DoDot:1
+6 IF ^DIC(19,DA,15)=$PIECE($TEXT(P4+1),";",3)
QUIT
+7 SET DIE="^DIC(19,"
SET DR="15///"_$PIECE($TEXT(P4+1),";",3)
+8 DO ^DIE
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
