AG7ENV ;IHS/ASDS/EFG - Patient Registration 7.0 ;
;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
;
; THIS IS A COPY OF GEORGE HUGGINS ENVIRONMENT CHECKER FOR V 6.0-P16
;
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)_".")
;
Q:'$$VCHK("AG","6.0",2)
Q:'$$VCHK("DI","21.0",2)
Q:'$$VCHK("XU","8.0",2)
;
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
;
Q:'$$VCHK("AUPN","99.1",2)
;
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 '$$INSTALLD("AG*6.0*14") 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
;
VCHK(AGPRE,AGVER,AGQUIT) ; Check versions needed.
;
NEW AGV
S AGV=$$VERSION^XPDUTL(AGPRE)
W !,$$CJ^XLFSTR("Need at least "_AGPRE_" v "_AGVER_"....."_AGPRE_" v "_AGV_" Present",IOM)
I AGV<AGVER KILL DIFQ S XPDQUIT=AGQUIT W *7,!,$$CJ^XLFSTR("Sorry....",IOM) S AGV=$$DIR^XBDIR("E","Press RETURN") Q 0
Q 1
;
PRE ;EP - From KIDS.
Q
;
POST ;EP - From KIDS.
D BMES^XPDUTL("Beginning post-install routine (POST^AG6P16).")
;
I '$$INSTALLD("AG*6.0*14") D IP14
;
I '$$INSTALLD("AG*6.0*15") D IP15
;
D BMES^XPDUTL("Restoring ""AGMENU"" option to PRE-install configuration...")
D OPTRES("AGMENU")
;
D P4
;
D BMES^XPDUTL("Saving 7 AGTX* post-P16 routines, just in case....")
D DELAFT^AGTXCONF,AFTSAV^AGTXCONF
;
D BMES^XPDUTL("Delivering AG*6*16 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("AG6P16MS",$J)
S ^TMP("AG6P16MS",$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("AG6P16MS",$J,(%+1))=" "_^(%,0)
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AG6P16MS"",$J,",XMY(1)="",XMY(DUZ)=""
F %="AGZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("AG6P16MS",$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^AG6P16.")
.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("AG6P16",6.15,"OPTSAV",AGM)) D BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' has previously been saved.") Q
I '$D(^XTMP("AG6P16")) S ^XTMP("AG6P16",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"AG6P16 - 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("AG6P16",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("AG6P16",6.15,"OPTSAV",AGM)) D BMES^XPDUTL("FAILED. Option '"_AGM_"' was not previously saved.") Q
S AG=0
F S AG=$O(^XTMP("AG6P16",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("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
;
IP15 ;
D BMES^XPDUTL("Patch 15 was not installed. Performing P15 items...")
;
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
Q
;
INSTALLD(AGINSTAL) ;EP - Determine if patch AGINSTAL was installed, where AGINSTAL is
; the name of the INSTALL. E.g "AG*6.0*10".
;;^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=$P(AGINSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",22,",X=$P(AGINSTAL,"*",2)
D ^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(AGINSTAL,"*",3)
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
;
AG7ENV ;IHS/ASDS/EFG - Patient Registration 7.0 ;
+1 ;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
+2 ;
+3 ; THIS IS A COPY OF GEORGE HUGGINS ENVIRONMENT CHECKER FOR V 6.0-P16
+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 IF '$$VCHK("AG","6.0",2)
QUIT
+14 IF '$$VCHK("DI","21.0",2)
QUIT
+15 IF '$$VCHK("XU","8.0",2)
QUIT
+16 ;
+17 SET X=$$VERSION^XPDUTL("AUT")
+18 WRITE !,$$C^XBFUNC("Need at least AUT 98.1.....AUT "_X_" Present")
+19 IF X<98.1
IF +X'=1.1
DO SORRY(2)
QUIT
+20 ;
+21 IF '$$VCHK("AUPN","99.1",2)
QUIT
+22 ;
+23 NEW DA,DIC
+24 SET X="AG"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+25 DO IX^DIC
+26 IF Y<0
IF $DATA(^DIC(9.4,"C","AG"))
Begin DoDot:1
+27 WRITE !!,*7,*7,$$C^XBFUNC("You Have More Than One Entry In The"),!,$$C^XBFUNC("PACKAGE File with an ""AG"" prefix.")
+28 WRITE !,$$C^XBFUNC("One entry needs to be deleted.")
+29 WRITE !,$$C^XBFUNC("FIX IT! Before Proceeding."),!!,*7,*7,*7
+30 DO SORRY(2)
+31 IF $$DIR^XBDIR("E")
+32 QUIT
End DoDot:1
QUIT
+33 WRITE !,$$C^XBFUNC("No 'AG' dups in PACKAGE file")
+34 ;
+35 IF $GET(XPDENV)=1
Begin DoDot:1
+36 ; The following line prevents the "Disable Options..." and "Move
+37 ; Routines..." questions from being asked during the install.
+38 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+39 IF '$$INSTALLD("AG*6.0*14")
DO BMES^XPDUTL("Saving 7 AGTX* routines, just in case....")
DO BEFSAV
+40 DO BMES^XPDUTL("Saving the configuration of option AGMENU...")
+41 DO OPTSAV("AGMENU")
+42 QUIT
End DoDot:1
+43 ;
+44 WRITE !!,$$C^XBFUNC("ENVIRONMENT OK.")
+45 ;
+46 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
QUIT
+47 QUIT
+48 ;
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 ;
VCHK(AGPRE,AGVER,AGQUIT) ; Check versions needed.
+1 ;
+2 NEW AGV
+3 SET AGV=$$VERSION^XPDUTL(AGPRE)
+4 WRITE !,$$CJ^XLFSTR("Need at least "_AGPRE_" v "_AGVER_"....."_AGPRE_" v "_AGV_" Present",IOM)
+5 IF AGV<AGVER
KILL DIFQ
SET XPDQUIT=AGQUIT
WRITE *7,!,$$CJ^XLFSTR("Sorry....",IOM)
SET AGV=$$DIR^XBDIR("E","Press RETURN")
QUIT 0
+6 QUIT 1
+7 ;
PRE ;EP - From KIDS.
+1 QUIT
+2 ;
POST ;EP - From KIDS.
+1 DO BMES^XPDUTL("Beginning post-install routine (POST^AG6P16).")
+2 ;
+3 IF '$$INSTALLD("AG*6.0*14")
DO IP14
+4 ;
+5 IF '$$INSTALLD("AG*6.0*15")
DO IP15
+6 ;
+7 DO BMES^XPDUTL("Restoring ""AGMENU"" option to PRE-install configuration...")
+8 DO OPTRES("AGMENU")
+9 ;
+10 DO P4
+11 ;
+12 DO BMES^XPDUTL("Saving 7 AGTX* post-P16 routines, just in case....")
+13 DO DELAFT^AGTXCONF
DO AFTSAV^AGTXCONF
+14 ;
+15 DO BMES^XPDUTL("Delivering AG*6*16 install message to select users...")
+16 DO MAIL
+17 ;
+18 DO BMES^XPDUTL("Post-install routine is complete.")
+19 QUIT
+20 ;
MAIL ; Send install mail message.
+1 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+2 KILL ^TMP("AG6P16MS",$JOB)
+3 SET ^TMP("AG6P16MS",$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("AG6P16MS",$JOB,(%+1))=" "_^(%,0)
+6 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AG6P16MS"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+7 FOR %="AGZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+8 DO ^XMD
+9 KILL ^TMP("AG6P16MS",$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^AG6P16.")
+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("AG6P16",6.15,"OPTSAV",AGM))
DO BMES^XPDUTL("NOT SAVED. Option '"_AGM_"' has previously been saved.")
QUIT
+2 IF '$DATA(^XTMP("AG6P16"))
SET ^XTMP("AG6P16",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"AG6P16 - 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("AG6P16",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("AG6P16",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("AG6P16",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("Q'ing Name check report...")
+6 SET ZTRTN="START^AGEDNAME"
SET ZTIO=""
SET ZTDESC=$PIECE($PIECE($TEXT(+1^AGEDNAME),";",2)," ",3,99)
SET ZTDTH=$HOROLOG
+7 DO ^%ZTLOAD
+8 IF $DATA(ZTSK)
DO MES^XPDUTL("Que'd to task "_ZTSK_".")
IF 1
+9 IF '$TEST
DO BMES^XPDUTL("Que of Name check report *FAILED*.")
+10 ;
+11 DO BMES^XPDUTL("Attaching ""AG REP NAME CHECK"" option to menu ""REGISTRATION REPORTS"".")
+12 IF $$ADD^XPDMENU("AGREPORTS","AG REP NAME CHECK","STD",25)
DO BMES^XPDUTL("....successfully atch'd....allocating Security Keys...")
Begin DoDot:1
+13 NEW AG,DA,DIC,DINUM
+14 SET AG=0
SET AG("RPT")=$ORDER(^DIC(19.1,"B","AGZREPORTS",0))
SET AG("STD")=$ORDER(^DIC(19.1,"B","AGZNAMECHECK",0))
+15 IF 'AG("RPT")!'AG("STD")
QUIT
+16 SET DIC(0)="NMQ"
SET DIC("P")="200.051PA"
+17 FOR
SET AG=$ORDER(^XUSEC("AGZREPORTS",AG))
IF 'AG
QUIT
Begin DoDot:2
+18 IF $DATA(^VA(200,AG,51,AG("STD")))
QUIT
+19 SET DIC="^VA(200,AG,51,"
SET DA(1)=AG
SET (DINUM,X)=AG("STD")
+20 DO FILE^DICN
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
IF 1
+23 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+24 ;
+25 DO BMES^XPDUTL("Attaching ""AGTXALL"" option to the export menu ""AGTX"".")
+26 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
+27 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+28 ;
+29 DO BMES^XPDUTL("Attaching ""AG TX CONFIG"" option to the export menu ""AGTX"".")
+30 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
+31 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+32 ;
+33 QUIT
+34 ;
IP15 ;
+1 DO BMES^XPDUTL("Patch 15 was not installed. Performing P15 items...")
+2 ;
+3 DO BMES^XPDUTL("Attaching ""AG TM ELIGIBILITY"" option to the table maintenance menu ""TM"".")
+4 IF $$ADD^XPDMENU("AG TM MENU","AG TM ELIGIBILITY","ELUP",10)
DO BMES^XPDUTL("....successfully atch'd.")
IF 1
+5 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+6 ;
+7 DO BMES^XPDUTL("Attaching ""AG3PSUM"" option to the the Third Party Billing Reports ""THR"".")
+8 IF $$ADD^XPDMENU("AGBILL","AG3PSUM","AGSM",4)
DO BMES^XPDUTL("....successfully atch'd.")
IF 1
+9 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+10 ;
+11 IF $$VAL^XBDIQ1(9999999.39,1,.15)'="YES"
Begin DoDot:1
+12 NEW AG
+13 SET AG=0
+14 FOR
SET AG=$ORDER(^ABMDCLM(AG))
IF 'AG
QUIT
IF $$FMDIFF^XLFDT(DT,$ORDER(^ABMDCLM(AG,"AC",9999999),-1),1)<180
Begin DoDot:2
+15 NEW DA,DIE,DR
+16 SET DIE=9999999.39
SET DA=1
SET DR=".15///Y"
+17 DO ^DIE
+18 IF '$DATA(Y)
Begin DoDot:3
+19 DO BMES^XPDUTL("The 'THIRD-PARTY BILLING PRESENT' field in RPMS SITE had been changed to 'YES',")
+20 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.")
+21 QUIT
End DoDot:3
QUIT
+22 DO BMES^XPDUTL("** ERROR: EDIT OF .15 IN RPMS SITE FILE FAILED.")
+23 QUIT
End DoDot:2
QUIT
+24 QUIT
End DoDot:1
+25 QUIT
+26 ;
INSTALLD(AGINSTAL) ;EP - Determine if patch AGINSTAL was installed, where AGINSTAL is
+1 ; the name of the INSTALL. E.g "AG*6.0*10".
+2 ;;^DIC(9.4,D0,22,D1,PAH,D2,0)=
+3 ;;(#.01) PATCH APPLICATION HISTORY [1F] ^ (#.02)DATE APPLIED [2D] ^ (#.03) APPLIED BY [3P] ^
+4 NEW DIC,X,Y
+5 SET X=$PIECE(AGINSTAL,"*",1)
+6 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+7 DO IX^DIC
+8 IF Y<1
QUIT 0
+9 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(AGINSTAL,"*",2)
+10 DO ^DIC
+11 IF Y<1
QUIT 0
+12 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(AGINSTAL,"*",3)
+13 DO ^DIC
+14 QUIT $SELECT(Y<1:0,1:1)
+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 ;
