Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AG6P16

AG6P16.m

Go to the documentation of this file. 
  1. AG6P16 ;IHS/ASDST/GTH - Patient Registration 6.0 Patch 16 ; 
  1.  ;;7.1;IHS PATIENT REGISTRATION;;AUG 25,2005
  1.  ;
  1.  ; IHS/ASDST/GTH AG*6*16 01/04/2002
  1.  ;
  1.  I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
  1.  ;
  1.  I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
  1.  ;
  1.  S X=$P(^VA(200,DUZ,0),U)
  1.  W !!,$$C^XBFUNC("Hello, "_$P(X,",",2)_" "_$P(X,","))
  1.  W !!,$$C^XBFUNC("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".")
  1.  ;
  1.  Q:'$$VCHK("AG","6.0",2)
  1.  Q:'$$VCHK("DI","21.0",2)
  1.  Q:'$$VCHK("XU","8.0",2)
  1.  ;
  1.  S X=$$VERSION^XPDUTL("AUT")
  1.  W !,$$C^XBFUNC("Need at least AUT 98.1.....AUT "_X_" Present")
  1.  I X<98.1,+X'=1.1 D SORRY(2) Q
  1.  ;
  1.  Q:'$$VCHK("AUPN","99.1",2)
  1.  ;
  1.  NEW DA,DIC
  1.  S X="AG",DIC="^DIC(9.4,",DIC(0)="",D="C"
  1.  D IX^DIC
  1.  I Y<0,$D(^DIC(9.4,"C","AG")) D  Q
  1.  . W !!,*7,*7,$$C^XBFUNC("You Have More Than One Entry In The"),!,$$C^XBFUNC("PACKAGE File with an ""AG"" prefix.")
  1.  . W !,$$C^XBFUNC("One entry needs to be deleted.")
  1.  . W !,$$C^XBFUNC("FIX IT! Before Proceeding."),!!,*7,*7,*7
  1.  . D SORRY(2)
  1.  . I $$DIR^XBDIR("E")
  1.  .Q
  1.  W !,$$C^XBFUNC("No 'AG' dups in PACKAGE file")
  1.  ;
  1.  I $G(XPDENV)=1 D
  1.  . ; The following line prevents the "Disable Options..." and "Move
  1.  . ; Routines..." questions from being asked during the install.
  1.  . S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  . I '$$INSTALLD("AG*6.0*14") D BMES^XPDUTL("Saving 7 AGTX* routines, just in case...."),BEFSAV
  1.  . D BMES^XPDUTL("Saving the configuration of option AGMENU...")
  1.  . D OPTSAV("AGMENU")
  1.  .Q
  1.  ;
  1.  W !!,$$C^XBFUNC("ENVIRONMENT OK.")
  1.  ;
  1.  I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
  1.  Q
  1.  ;
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  S XPDQUIT=X
  1.  W:'$D(ZTQUEUED) *7,!,$$C^XBFUNC("Sorry...."),$$DIR^XBDIR("E","Press RETURN")
  1.  Q
  1.  ;
  1. VCHK(AGPRE,AGVER,AGQUIT) ; Check versions needed.
  1.  ;  
  1.  NEW AGV
  1.  S AGV=$$VERSION^XPDUTL(AGPRE)
  1.  W !,$$CJ^XLFSTR("Need at least "_AGPRE_" v "_AGVER_"....."_AGPRE_" v "_AGV_" Present",IOM)
  1.  I AGV<AGVER KILL DIFQ S XPDQUIT=AGQUIT W *7,!,$$CJ^XLFSTR("Sorry....",IOM) S AGV=$$DIR^XBDIR("E","Press RETURN") Q 0
  1.  Q 1
  1.  ;
  1. PRE ;EP - From KIDS.
  1.  Q
  1.  ;
  1. POST ;EP - From KIDS.
  1.  D BMES^XPDUTL("Beginning post-install routine (POST^AG6P16).")
  1.  ;
  1.  I '$$INSTALLD("AG*6.0*14") D IP14
  1.  ;
  1.  I '$$INSTALLD("AG*6.0*15") D IP15
  1.  ;
  1.  D BMES^XPDUTL("Restoring ""AGMENU"" option to PRE-install configuration...")
  1.  D OPTRES("AGMENU")
  1.  ;
  1.  D P4
  1.  ;
  1.  D BMES^XPDUTL("Saving 7 AGTX* post-P16 routines, just in case....")
  1.  D DELAFT^AGTXCONF,AFTSAV^AGTXCONF
  1.  ;
  1.  D BMES^XPDUTL("Delivering AG*6*16 install message to select users...")
  1.  D MAIL
  1.  ;
  1.  D BMES^XPDUTL("Post-install routine is complete.")
  1.  Q
  1.  ;
  1. MAIL ; Send install mail message.
  1.  NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
  1.  KILL ^TMP("AG6P16MS",$J)
  1.  S ^TMP("AG6P16MS",$J,1)=" --- AG v 6, Patch 15, has been installed into this uci ---"
  1.  S %=0
  1.  F  S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'%   S ^TMP("AG6P16MS",$J,(%+1))=" "_^(%,0)
  1.  S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AG6P16MS"",$J,",XMY(1)="",XMY(DUZ)=""
  1.  F %="AGZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
  1.  D ^XMD
  1.  KILL ^TMP("AG6P16MS",$J)
  1.  Q
  1.  ;
  1. SINGLE(K) ; Get holders of a single key K.
  1.  NEW Y
  1.  S Y=0
  1.  Q:'$D(^XUSEC(K))
  1.  F  S Y=$O(^XUSEC(K,Y)) Q:'Y  S XMY(Y)=""
  1.  Q
  1.  ;
  1.  ;
  1. INDEXAI ; REINDEX AI XREF PREVIOUS COMMUNITY 
  1.  ;
  1.  ; Thanks to Toni Jarland for the original routine.  Aug 17 2001.
  1.  ;
  1.  ;This runs the AI X-Ref Re-Index of the Previous Communty Multiple
  1.  ;$Order through each AUPNPAT Global Entry & Re-Index AI X-Ref
  1.  ;The AI X-Ref calls Routine AUPNPCTR which $O thru the Previous
  1.  ;Community Multiple & resets the Last Previous Community Entry
  1.  ;to fields #1117 Current Community Mulitple & #1118 Current Community
  1.  ;Text Value.  This will clean up missing Community Pointers used
  1.  ;in the Patient Registration Re-export
  1.  ;
  1.  I $P($T(+2^AUPNPCTR),";",5)'="**6**" D  Q
  1.  . D BMES^XPDUTL("AUPN PATCH 6 IS NOT INSTALLED.")
  1.  . D BMES^XPDUTL("THE AI X-REF RE-FIRE WILL BE IN VAIN.")
  1.  . D BMES^XPDUTL("INSTALL AUPN 99.1 PATCH 6 AND RUN INDEXAI^AG6P16.")
  1.  .Q
  1.  NEW AGB,AGE
  1.  S AGB=$$NOW^XLFDT
  1.  D BMES^XPDUTL("Begin Re-Indexing AI Cross Reference of PATIENT File, "_$$FMTE^XLFDT(AGB))
  1.  W:'$D(ZTQUEUED) !,"Estimated % complete:",!
  1.  NEW AGP3,DA,DIK
  1.  S DA(1)=0,DIK(1)=".03^AI",AGP3=$P(^AUPNPAT(0),U,3)
  1.  F  S DA(1)=$O(^AUPNPAT(DA(1))) Q:'DA(1)  D
  1.  . S DIK="^AUPNPAT("_DA(1)_",51,"
  1.  . D ENALL^DIK
  1.  . I '(DA(1)#100),'$D(ZTQUEUED) W " | ",$J(DA(1)/AGP3*100,0,0),"%"
  1.  .Q
  1.  ;
  1.  S AGE=$$NOW^XLFDT
  1.  D BMES^XPDUTL("End of Re-Indexing AI Cross Reference of PATIENT File, "_$$FMTE^XLFDT(AGE))
  1.  D BMES^XPDUTL($$FMDIFF^XLFDT(AGE,AGB,2)_" seconds")
  1.  Q
  1.  ;
  1. BEFSAV ;this is the same s/r as in AGTXCONF.
  1.  NEW AG,AGM,XCN,XCNP,DIE,DIF
  1.  F AG=1:1:7 D
  1.  . D KT
  1.  . S X=$P($T(BEF+AG),";",3),(XCN,XCNP)=0,(DIE,DIF)="^TMP(""AGTXCONF"",$J,"
  1.  . S AGM="Loading '"_X_"'..."
  1.  . X ^%ZOSF("LOAD")
  1.  . S X=$P($T(BEF+AG),";",4)
  1.  . X ^%ZOSF("TEST")
  1.  . I  D MES^XPDUTL(AGM_"NOT SAVED AS '"_X_"'.  '"_X_"' ALREADY EXISTS.") Q
  1.  . X ^%ZOSF("SAVE")
  1.  . D MES^XPDUTL(AGM_"Saved as '"_X_"'.")
  1.  .Q
  1.  D KT
  1.  Q
  1.  ;
  1. KT KILL ^TMP("AGTXCONF",$J)
  1.  Q
  1.  ;
  1. BEF ; These are the "before p15" routines.
  1.  ;;AGTX1;AGTXX1
  1.  ;;AGTX2;AGTXX2
  1.  ;;AGTX3;AGTXX3
  1.  ;;AGTX4;AGTXX4
  1.  ;;AGTX5;AGTXX5
  1.  ;;AGTXST;AGTXX6
  1.  ;;AGTXTAPE;AGTXX7
  1.  ;
  1. OPTSAV(AGM) ;
  1.  I $D(^XTMP("AG6P16",6.15,"OPTSAV",AGM)) D BMES^XPDUTL("NOT SAVED.  Option '"_AGM_"' has previously been saved.") Q
  1.  I '$D(^XTMP("AG6P16")) S ^XTMP("AG6P16",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"AG6P16 - SAVE OPTION CONFIGURATIONS."
  1.  NEW I,A
  1.  S I=$O(^DIC(19,"B",AGM,0))
  1.  I 'I D BMES^XPDUTL("NOT SAVED.  Option '"_AGM_"' not found in OPTION file.") Q
  1.  S A=0
  1.  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)
  1.  Q
  1.  ;
  1. OPTRES(AGM) ;
  1.  NEW AG,AGI
  1.  I '$D(^XTMP("AG6P16",6.15,"OPTSAV",AGM)) D BMES^XPDUTL("FAILED.  Option '"_AGM_"' was not previously saved.") Q
  1.  S AG=0
  1.  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_".")
  1.  Q
  1.  ;
  1. IP14 ; Items from patch 14.
  1.  D BMES^XPDUTL("Patch 14 was not installed.  Performing P14 items...")
  1.  ;
  1.  D INDEXAI
  1.  ;
  1.  D BMES^XPDUTL("Q'ing Name check report...")
  1.  S ZTRTN="START^AGEDNAME",ZTIO="",ZTDESC=$P($P($T(+1^AGEDNAME),";",2)," ",3,99),ZTDTH=$H
  1.  D ^%ZTLOAD
  1.  I $D(ZTSK) D MES^XPDUTL("Que'd to task "_ZTSK_".") I 1
  1.  E  D BMES^XPDUTL("Que of Name check report *FAILED*.")
  1.  ;
  1.  D BMES^XPDUTL("Attaching ""AG REP NAME CHECK"" option to menu ""REGISTRATION REPORTS"".")
  1.  I $$ADD^XPDMENU("AGREPORTS","AG REP NAME CHECK","STD",25) D BMES^XPDUTL("....successfully atch'd....allocating Security Keys...") D  I 1
  1.  . NEW AG,DA,DIC,DINUM
  1.  . S AG=0,AG("RPT")=$O(^DIC(19.1,"B","AGZREPORTS",0)),AG("STD")=$O(^DIC(19.1,"B","AGZNAMECHECK",0))
  1.  . Q:'AG("RPT")!'AG("STD")
  1.  . S DIC(0)="NMQ",DIC("P")="200.051PA"
  1.  . F  S AG=$O(^XUSEC("AGZREPORTS",AG)) Q:'AG  D
  1.  .. Q:$D(^VA(200,AG,51,AG("STD")))
  1.  .. S DIC="^VA(200,AG,51,",DA(1)=AG,(DINUM,X)=AG("STD")
  1.  .. D FILE^DICN
  1.  ..Q
  1.  .Q
  1.  E  D BMES^XPDUTL("....Attachment *FAILED*.")
  1.  ;
  1.  D BMES^XPDUTL("Attaching ""AGTXALL"" option to the export menu ""AGTX"".")
  1.  I $$ADD^XPDMENU("AGTX","AGTXALL","ALL",10) D BMES^XPDUTL("....successfully atch'd."),BMES^XPDUTL("NOTE: Security key will *NOT* be allocated.") I 1
  1.  E  D BMES^XPDUTL("....Attachment *FAILED*.")
  1.  ;
  1.  D BMES^XPDUTL("Attaching ""AG TX CONFIG"" option to the export menu ""AGTX"".")
  1.  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
  1.  E  D BMES^XPDUTL("....Attachment *FAILED*.")
  1.  ;
  1.  Q
  1.  ;
  1. IP15 ;
  1.  D BMES^XPDUTL("Patch 15 was not installed.  Performing P15 items...")
  1.  ;
  1.  D BMES^XPDUTL("Attaching ""AG TM ELIGIBILITY"" option to the table maintenance menu ""TM"".")
  1.  I $$ADD^XPDMENU("AG TM MENU","AG TM ELIGIBILITY","ELUP",10) D BMES^XPDUTL("....successfully atch'd.") I 1
  1.  E  D BMES^XPDUTL("....Attachment *FAILED*.")
  1.  ;
  1.  D BMES^XPDUTL("Attaching ""AG3PSUM"" option to the the Third Party Billing Reports ""THR"".")
  1.  I $$ADD^XPDMENU("AGBILL","AG3PSUM","AGSM",4) D BMES^XPDUTL("....successfully atch'd.") I 1
  1.  E  D BMES^XPDUTL("....Attachment *FAILED*.")
  1.  ;
  1.  I $$VAL^XBDIQ1(9999999.39,1,.15)'="YES" D
  1.  . NEW AG
  1.  . S AG=0
  1.  . F  S AG=$O(^ABMDCLM(AG)) Q:'AG  I $$FMDIFF^XLFDT(DT,$O(^ABMDCLM(AG,"AC",9999999),-1),1)<180 D  Q
  1.  .. NEW DA,DIE,DR
  1.  .. S DIE=9999999.39,DA=1,DR=".15///Y"
  1.  .. D ^DIE
  1.  .. I '$D(Y) D  Q
  1.  ... D BMES^XPDUTL("The 'THIRD-PARTY BILLING PRESENT' field in RPMS SITE had been changed to 'YES',")
  1.  ... 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.")
  1.  ...Q
  1.  .. D BMES^XPDUTL("** ERROR:  EDIT OF .15 IN RPMS SITE FILE FAILED.")
  1.  .. Q
  1.  .Q
  1.  Q
  1.  ;
  1. INSTALLD(AGINSTAL) ;EP - Determine if patch AGINSTAL was installed, where AGINSTAL is
  1.  ; the name of the INSTALL.  E.g "AG*6.0*10".
  1.  ;;^DIC(9.4,D0,22,D1,PAH,D2,0)=
  1.  ;;(#.01) PATCH APPLICATION HISTORY [1F] ^ (#.02)DATE APPLIED [2D] ^ (#.03) APPLIED BY [3P] ^ 
  1.  NEW DIC,X,Y
  1.  S X=$P(AGINSTAL,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 Q 0
  1.  S DIC=DIC_+Y_",22,",X=$P(AGINSTAL,"*",2)
  1.  D ^DIC
  1.  I Y<1 Q 0
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(AGINSTAL,"*",3)
  1.  D ^DIC
  1.  Q $S(Y<1:0,1:1)
  1.  ;
  1. 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
  1.  ;
  1.  NEW DA,DIE,DR
  1.  S DA=""
  1.  F  S DA=$O(^DIC(19,"B","AGMENU",DA)) Q:DA=""  D
  1.  . Q:^DIC(19,DA,15)=$P($T(P4+1),";",3)
  1.  . S DIE="^DIC(19,",DR="15///"_$P($T(P4+1),";",3)
  1.  . D ^DIE
  1.  .Q
  1.  Q