ACHSPRE ;IHS/ITSC/PMF - ENVIRONMENT CHECK-NAMESPACE CLEANUP ; [ 11/19/2001 8:18 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
S $ZT="ERROR"
S U="^",CM=","
;
I 'XPDENV,$D(^ACHSINST) D
. M ^ACHSINS1=^ACHSINST
. S G="" F S G=$O(^ACHSINST(G)) Q:G="" K ^ACHSINST(G)
. Q
;
S ^ACHSINST="",G=$$NOJOURN^ZIBGCHAR("ACHSINIT")
;
S ACHSVERS="V"_$P($T(+2),";",3)
S $P(LINE,"*",81)=""
;
I $D(^%ZOSF("MAXSIZ")) S X=250 X ^%ZOSF("MAXSIZ")
;
;GET THE CURRENT VERSION INSTALLED
S PACKNUM=$O(^DIC(9.4,"B",$P($T(+2),";",4),""))
I PACKNUM="" D Q
.W !,$$C^XBFUNC("THERE IS SOMETHING WRONG WITH YOUR PACKAGE FILE!!")
.W !,$$C^XBFUNC("THE PACKAGE IEN COULD NOT BE FOUND IN FILE #9.4!")
.S XPDABORT=1
.D SORRY
;
S CVERSION=$G(^DIC(9.4,PACKNUM,"VERSION"))
I CVERSION="" D Q
.W !,"THERE IS SOMETHING WRONG WITH YOUR PACKAGE FILE!!"
.W !,"THE PACKAGE VERSION IN FILE #9.4 COULD NOT BE FOUND!"
.S XPDABORT=1
.D SORRY
;
W !,"Checking, please wait..."
D INT^%SP
I %FTOTBLK/%TOTBLK*100<2 D Q
. W !,"YOU HAVE LESS THAN 2% FREE SPACE. THIS IS NOT ENOUGH SPACE TO DO THE INSTALL."
. S XPDABORT=1
. D SORRY
. Q
;
W !,"More checking, please wait..."
S TOTBYT=0,GLOB="^ACHSDEN"
F S GLOB=$Q(@GLOB) Q:GLOB="" S TOTBYT=TOTBYT+$L(GLOB)+$L(@GLOB)
I TOTBYT*2.5/1012>%FTOTBLK D Q
. W !,"YOU DO NOT HAVE ENOUGH FREE SPACE TO RUN THIS INSTALL."
. S XPDABORT=1
. D SORRY
. Q
;
;if we are doing the initial check prior to installing, it's time
;to do the conversion
I 'XPDENV D CONV
I $G(STOP) D Q
. W !,"THE TRIAL CONVERSION OF THE DENIAL DATA HAS FAILED"
. S XPDABORT=1 D SORRY
. Q
;
I 'XPDENV W !!,"THE ENVIRONMENT CHECK WILL BE RUN WHEN THE INSTALL OPTION IS USED!" Q
;
;END of pre install check
;
S XPDABORT=0
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"DUZ VARIABLES NOT SET")=NOW S XPDABORT=1 D SORRY Q
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"DUZ VARIABLES NOT SET")=NOW S XPDABORT=1 D SORRY Q
S INSTALER=$P($G(^VA(200,DUZ,0)),U)
I INSTALER="" S %H=$H D YX^%DTC S NOW=Y S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"UNKNOWN INSTALLER")=NOW S XPDABORT=1 D SORRY Q
;
ASKBACK ;
S DIR(0)="Y^^"
S DIR("A")="Has a SYSTEM BACKUP been successfully performed?"
S DIR("B")="NO"
S DIR("?")="Answer YES if backups were successfully performed."
D ^DIR
I $D(DUOUT) W !,"User initiated abort!",!,"Aborting installation!" S ERROR=1,XPDABORT=1 S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"USER INITIATED ABORT!")=NOW Q
I 'Y W !!,"Aborting installation!!" S ERROR=1,XPDABORT=1 S:Y="" ^ACHSINST(ACHSVERS,"ERROR",$ZN,"PROMPT TIMED OUT!")=NOW Q
ASKCAPT ;
S DIR(0)="Y^^"
S DIR("A")="Has the 'Capture to file' option been turned on?"
S DIR("B")="NO"
S DIR("?")="Answer YES if the 'Capture to file' option is ON."
D ^DIR
I $D(DUOUT) W !,"User initiated abort!",!,"Aborting installation!!" S ERROR=1,XPDABORT=1 S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"USER INITIATED ABORT!")=NOW Q
I 'Y W !!,"Aborting installation!!" S ERROR=1,XPDABORT=1 S:Y="" ^ACHSINST(ACHSVERS,"ERROR",$ZN,"PROMPT TIMED OUT!")=NOW Q
;
;
D HOME^%ZIS,DT^DICRW
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"CHS INSTALL","STATUS","INSTALL BEGUN")=NOW
S ^ACHSINST(ACHSVERS,$ZN,"ENTERED")=NOW
W !,LINE
W !,$$C^XBFUNC("Hello, "_$P(INSTALER,CM,2)_" "_$P(INSTALER,CM)),!!,$$C^XBFUNC("Checking Environment for Installation of")
W !,$$C^XBFUNC("VERSION "_$P($T(+2),";",3)_" of "_$P($T(+2),";",4)_".")
S X=$G(^DD("VERSION"))
;
W !!,"Need at least FileMan 21.....FileMan "_X_" Present"
I X<21 S ^ACHSINST(ACHSVERS,"ERROR","ONLY HAVE FILEMAN "_X)=NOW W " Not Present!" D SORRY Q
S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XU",0)),"VERSION"))
W !!,"Need at least Kernel 7.1.....Kernel "_X_" Present"
I X<7.1 S ^ACHSINST(ACHSVERS,"ERROR","ONLY HAVE KERNEL "_X)=NOW W " Not Present!" D SORRY Q
W !!,"Need HFS interface to Kernel (^%ZISH)....."
S ACHS=1
S ACHSRCHK="'$L($T(@X"_$S($G(^%ZOSF("OS"))["UNIX":"^%ZISH",1:"^ZISHMSMD")_"))"
F X="OPEN","DEL","SEND","LIST","STATUS" I @ACHSRCHK W !,$J("",20)_X_"^%ZISH not Present" S ACHS=0
I 'ACHS S ^ACHSINST(ACHSVERS,"ERROR","NEED HFS INTERFACE ^%ZISH ROUTINES")=NOW D SORRY Q
;
S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XB",0)),"VERSION"))
W !!,"Need XB/ZIB, v 3.0.....XB/ZIB "_X_" Present"
I X<3 S ^ACHSINST(ACHSVERS,"ERROR","NEED XB/ZIB INSTALLED")=NOW W " Not Present!" D SORRY Q
;
S X=$P($T(+2^AUTTVLK),";",3)
S X=$S(X<89:"20"_X,1:"19"_X)
S X=$S(X>1998:"Looks OK...",1:"")
W !!,"Need AUT IHS Standard Data Dictionaries, at least v 98.1 ...."_X
I '$L(X) S ^ACHSINST(ACHSVERS,"ERROR","NEED AUTT VERSION 98.1")=NOW S XPDABORT=1 W " Not OK!" D SORRY Q
S X=$P($T(+2^AUPNPAT),";",3)
S X=$S(X<89:"20"_X,1:"19"_X)
S X=$S(X>1999:"Looks OK...",1:"")
W !!,"Need AUPN, at least v 99.1 ...."_X
I '$L(X) S ^ACHSINST(ACHSVERS,"ERROR","NEED AUPN VERSION 99.1")=NOW S XPDABORT=1 W " Not OK!" D SORRY Q
K ^TMP("ACHSPOST",$J)
;
;check conversion finished node
S RUNTIME="" F S RUNTIME=$O(^ACHS("V3.1","denial conversion","AMOCK",RUNTIME)) Q:RUNTIME="" I +$G(^(RUNTIME)) Q
;
;10/31/01 pmf only check for the conversion if they are
;not already 3.1. replace one line
;I RUNTIME="" D Q
I RUNTIME="",(CVERSION<3.1) D Q
. W !!,"CONVERSION OF DENIAL DATA NOT FOUND"
. S ^ACHSINST(ACHSVERS,"ERROR","CONVERSION NOT COMPLETE"_X)=NOW D SORRY
. Q
;
W !!,$$C^XBFUNC("ENVIRONMENT OK.")
W !,LINE
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,$ZN,"ENVIRONMENT CHECK OK")=NOW
;
S %H=$H D YMD^%DTC
D DELDD
;
W !!,"CHS DICTIONARIES FROM PREVIOUS VERSION HAVE BEEN DELETED!"
D DELRTN
S ^ACHSINST(ACHSVERS,$ZN,"CHS NAMESPACE DELETIONS FINISHED")=NOW
W !!,"CHS ROUTINES FROM PREVIOUS VERSION HAVE BEEN DELETED!"
W !!,LINE
K ^TMP("ACHSPOST")
Q
;
SORRY ;
K DIFQ
W *7,!!!,$$C^XBFUNC("Sorry....something is wrong with your environment")
W !,$$C^XBFUNC("Aborting Contract Health System install!")
W !,$$C^XBFUNC("Please print/capture this screen and notify")
W !,$$C^XBFUNC("the Support Team")
W !!,LINE
S %H=$H D YX^%DTC S NOW=Y
S XPDABORT=1
;
S ^ACHSINST(ACHSVERS,$ZN,"ENVIRONMENT CHECK FAILED")=NOW
S ^ACHSINST(ACHSVERS,$ZN,"ABORTED")=NOW
;
S Y=$$DIR^XBDIR("E","Press RETURN To Continue...","","","",1) X ^%ZOSF("TRMRD")
Q
;
DELRTN ;
S XPDIDTOT=384,XPDIDVT=10,XGCURATR=10,IOBM=10
D INIT^XPDID
D TITLE^XPDID("DELETING OLD CHS ROUTINES")
D SAY^XGF(10,10,"DELETING CHS ROUTINES.....")
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DELRTN^"_$ZN,"ENTERED")=NOW
S %RN="ACHRZZZ" F COUNT=1:1 S %RN=$O(^(%RN)) Q:%RN'[("ACH")&(%RN'[("AZZZE")) D
.S $P(FILLER," ",IOM-$L(%RN))=""
.D SAY^XGF(12,10,"DELETING "_%RN_"....."_FILLER)
.X "ZR ZS @%RN"
.D UPDATE^XPDID(COUNT)
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DELRTN^"_$ZN,"FINISHED")=NOW
D UPDATE^XPDID(0)
D EXIT^XPDID("FINISHED WITH CHS ROUTINE DELETE!")
Q
;
DELDD ;
S XPDIDTOT=20,XPDIDVT=10,XGCURATR=10,IOBM=10
D INIT^XPDID,TITLE^XPDID("DELETING OLD CHS DATA DICTIONARIES")
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DELDD^"_$ZN,"ENTERED")=NOW
F GLO="^DIC(","^DD(" D
.S FILENUM=9002060.999999
.F COUNT=1:1 S FILENUM=$O(@(GLO_FILENUM_")")) Q:FILENUM>9002080.999999 D
..S GLOBAL=GLO_FILENUM_")"
..I '$D(@GLOBAL) D SAY^XGF(12,10,GLOBAL_" NOT FOUND ON THIS SYSTEM!") Q
..D UPDATE^XPDID(COUNT)
..D SAY^XGF(12,10,"KILLING GLOBAL "_GLOBAL_" ..........")
..K @GLOBAL
S TMP=$O(^DIC("B","CHS DEFERRED SERVICES CATEGORY",""))
K:TMP=9002068 ^DIC("B","CHS DEFERRED SERVICES CATEGORY",9002068)
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"DELDD^"_$ZN,"FINISHED")=NOW
D UPDATE^XPDID(0)
D EXIT^XPDID("FINISHED WITH CHS DATA DICTIONARY DELETE!")
Q
;
CONV ; CONVERT CHS DENIAL DATA FROM OLD TO NEW STRUCTURE
;
S %H=$H D YX^%DTC S NOW=Y,RUNTIME=Y
I '$G(CVERSION) S ^ACHSINST(ACHSVERS,$ZN,"CONVERSION NOT DONE, FIRST TIME INSTALL")=NOW Q
;
I +CVERSION>3 W !!,"THE CURRENT VERSION OF CHS IS HIGER THAN 3.0",!,"CONVERSION PROCESS WILL BE BYPASSED!" S ^ACHSINST(ACHSVERS,$ZN,"CONVERSION BYPASSED DUE TO HIGH VERSION")=NOW Q
;
S LINE=$G(LINE)
W !!,LINE,!!,"Starting trial conversion, please be patient"
S ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"ENTERED")=NOW
;
S (NUMENTRY,NUMERR,STOP)=0,QT=""""
;
;S NODE=$G(^ACHSINST(VERS,"CONVERSION",MOCK,"LAST NODE"))
S NODE=""
I NODE="" S NODE="^ACHSDEN"
;
;stop journaling on the globals, if they exist
S G=$$NOJOURN^ZIBGCHAR("ACHSDEN")
I $D(^ACHSDENY) S G=$$NOJOURN^ZIBGCHAR("ACHSDENY")
I $D(^ACHSDENZ) S G=$$NOJOURN^ZIBGCHAR("ACHSDENZ")
;
;kill off globals one and two, just in case they exist
S G="" F S G=$O(^ACHSDENY(G)) Q:G="" K ^(G)
S G="" F S G=$O(^ACHSDENZ(G)) Q:G="" K ^(G)
;
;establish top node of globals one and two
S ^ACHSDENY="",^ACHSDENZ=""
;stop journaling on the globals again, now that we know they exist
S G=$$NOJOURN^ZIBGCHAR("ACHSDEN"),G=$$NOJOURN^ZIBGCHAR("ACHSDENY"),G=$$NOJOURN^ZIBGCHAR("ACHSDENZ")
;
M ^ACHSDENZ=^ACHSDEN
S NEWNODE="^ACHSDENY("
;
D LOOP1
I 'STOP D SET1
I 'STOP D LOOP2
;
S %H=$H D YX^%DTC
S ^ACHS("V3.1","denial conversion","AMOCK",RUNTIME)='STOP_U_Y
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"FINISHED")=NOW
;
Q
;
LOOP1 ;
S $ZT="ERRORCN"
;
F S NODE=$Q(@NODE) Q:NODE=""!(STOP) D
. ;
. ;SKIP X-REFS WE DO NOT NEED TO CONVERT THESE.
. S FIRSTSUB=$P($P(NODE,CM),"(",2)
. I FIRSTSUB?1""""1A.E1"""" Q
. ;
. ;check for alpha subscripts, indicating a cross reference
. ;do not process these
. S FOUND=0 F XXI=3:1:99 S XXS=$P($P(NODE,"(",2),CM,XXI) Q:XXS="" I XXS?1""""1A.E1"""" S FOUND=1 Q
. K XXI,XXS I FOUND Q
. K FOUND
. ;CHECK FOR NEW DATA STRUCTURE MIXED WITH OLD, copy new data as is
. I NODE[("""D""") D ASIS Q
. I NODE[(",0)"),$L(NODE,CM)=2 D REC0 Q
. I NODE[(",10)") D REC10 Q
. I NODE[(",100)") D REC100 Q
. I NODE[(",200,") D REC200 Q
. I NODE[(",210,") D REC210 Q
. I NODE[(",290)") D REC290 Q
. I NODE[(",300,") D REC300 Q
. I NODE[(",400)") D REC400 Q
. I NODE[(",500,") D REC500 Q
. I NODE[(",600,") D REC600 Q
. I NODE[(",650)") D REC650 Q
. I NODE[(",700,") D REC700 Q
. Q
;
;that ends the main loop of the conversion
Q
;
SET1 ;
S NEWNODE="^ACHSDENY(0)"
S @NEWNODE="CHS DENIAL DATA^9002071I"_U_$S($G(ISSUEFAC)="":0,1:ISSUEFAC)_U_$S($G(NUMENTRY)="":0,1:NUMENTRY)
;
;DO COUNTS OF FACILITIES AND ITEMS WITHIN FACILITY
S FAC=0 F CNT=1:1 S FAC=$O(^ACHSDENY(FAC)) Q:+FAC=0 D
. S ITEM=0 F CNT2=1:1 S ITEM=$O(^ACHSDENY(FAC,"D",ITEM)) Q:+ITEM=0 D
.. S NEWNODE="^ACHSDENY("_FAC_CM_QT_"D"_QT_CM_"0)"
.. S @NEWNODE=U_"9002071.01A"_U_ITEM_U_CNT2
.. Q
. Q
;
Q
;
LOOP2 ;
;the data is now converted and sitting in ^ACHSDENY.
;here we set up the cross references for it.
W !!!,"Re-indexing new Denial file..."
;
S FAC=0 F S FAC=$O(^ACHSDENY(FAC)) Q:'+FAC Q:STOP S DEN=0 D LOOP2A
Q
;
LOOP2A ;
;note start of new error trap
S $ZT="ERRORXR"
;
F S DEN=$O(^ACHSDENY(FAC,"D",DEN)) Q:'+DEN Q:STOP D
. S DAT=$G(^ACHSDENY(FAC,"D",DEN,0))
. I DAT="" Q
. S NODE="^ACHSDENY("_FAC_CM_QT_"D"_QT_CM_DEN
. S DENIAL=$P(DAT,U,1),AISSUE=$P(DAT,U,2),ES=$P(DAT,U,4)
. I AISSUE'="" S ^ACHSDENY(FAC,"D","AISSUE",AISSUE,DEN)=""
. I DENIAL'="" S ^ACHSDENY(FAC,"D","B",DENIAL,DEN)=""
. I ES'="" S ^ACHSDENY(FAC,"D","ES",ES,DEN)=""
. Q
Q
;
W !,"Denial Updates Completed at ",$$FMTE^XLFDT(%)
S ^ACHSINST(ACHSVERS,"REINDEX^"_$ZN,"FINISHED")=NOW
;
Q
;
ASIS ;
;COPY AS IS THIS IS THE NEW DATA STRUCTURE
S RECORD=$G(@NODE)
S SUB1=$P(NODE,"(",2,299)
S ASISNODE="^ACHSDEN("_SUB1
S @ASISNODE=RECORD
;
Q
;
REC0 ;
;GET THE ZERO NODE AND REARRANGE THE PIECES
S NUMENTRY=NUMENTRY+1
I NUMENTRY#100=0 W !,?18,NUMENTRY," denials examined so far"
S REC0=$G(@NODE)
S DENIAL=$P(REC0,U)
S ISSUEDT=$P(REC0,U,2)
S SERVDT=$P(REC0,U,3)
S ISREG=$P(REC0,U,4)
S PAT=$P(REC0,U,5)
S ISSUEBY=$P(REC0,U,6)
S REQDT=$P(REC0,U,7)
S ISSUEFAC=$P(REC0,U,8)
;
I ISSUEFAC="" S ISSUEFAC=$O(^ACHSF("B",0))
;
S ENTRYNUM=$P($P(NODE,","),"(",2)
;
;CHECK FOR EXISTING ENTRIES HERE (THIS SHOULD ONLY HAPPEN IN SITES WITH
;THE OLD STRUCTURE MIXED WITH THE NEW)
I $D(^ACHSDEN(ISSUEFAC,"D",ENTRYNUM)) W !,"ENTRY "_ENTRYNUM_" ALREADY EXISTS FOR THIS "_ISSUEFAC_"!" S ENTRYNUM=$O(^ACHSDEN(ISSUEFAC,"D","A"),-1)+1
;
S NEWNODE="^ACHSDENY("_ISSUEFAC
;
S @(NEWNODE_",0)")=ISSUEFAC
S NODE0=NEWNODE_",""D"","_ENTRYNUM_",0)"
S @NODE0=DENIAL_U_ISSUEDT_U_ISSUEBY_U_SERVDT_U_REQDT_U_ISREG_U_PAT
;
Q
REC10 ;EP
S REC10=$G(@NODE) ;NO CHANGE IN PIECES
S NODE10=NEWNODE_",""D"","_ENTRYNUM_",10)"
S @NODE10=REC10
Q
REC100 ;EP
S REC100=$G(@NODE) ;NO CHANGE IN PIECES
S NODE100=NEWNODE_",""D"","_ENTRYNUM_",100)"
S @NODE100=REC100
Q
REC200 ;EP
S REC200=$G(@NODE)
I $P(REC200,U,2)="9002071.01PA" S $P(REC200,U,2)="9002071.02PA"
S NODE200=NEWNODE_",""D"","_ENTRYNUM_",200"_$S(ENTRYNUM=200:$P(NODE,"200,200",2,99),1:$P(NODE,",200",2,99))
S @NODE200=REC200
Q
REC210 ;EP
S REC210=$G(@NODE) ;NO CHANGE IN PIECES
I $P(REC210,U,2)="9002071.05A" S $P(REC210,U,2)="9002071.03A"
S NODE210=NEWNODE_",""D"","_ENTRYNUM_",210"_$S(ENTRYNUM=210:$P(NODE,"210,210",2,99),1:$P(NODE,",210",2,99))
S @NODE210=REC210
Q
REC290 ;EP
S REC290=$G(@NODE) ;CHANGE TO NODE 250 SAME PIECE
S NODE250=NEWNODE_",""D"","_ENTRYNUM_",250)"
S @NODE250=REC290
Q
REC300 ;EP
S REC300=$G(@NODE) ;NO CHANGE IN PIECES
I $P(REC300,U,2)="9002071.02PA" S $P(REC300,U,2)="9002071.04PA"
S NODE300=NEWNODE_",""D"","_ENTRYNUM_",300"_$S(ENTRYNUM=300:$P(NODE,"300,300",2,99),1:$P(NODE,",300",2,99))
S @NODE300=REC300
Q
REC400 ;EP
S REC400=$G(@NODE) ;PIECES CHANGE
S DEFSER=$P(REC400,U)
S PRICAT=$P(REC400,U,4)
S MPRICAT=""
S:PRICAT'="" MPRICAT=$O(^ACHSMPRI("B",PRICAT,MPRICAT))
S APPEAL=$P(REC400,U,5)
S NREC400=DEFSER_U_MPRICAT_U_APPEAL
S NODE400=NEWNODE_",""D"","_ENTRYNUM_",400)"
S @NODE400=NREC400
Q
REC500 ;EP
S REC500=$G(@NODE)
I $P(REC500,U,2)="9002071.03PA" S $P(REC500,U,2)="9002071.05PA"
S NODE500=NEWNODE_",""D"","_ENTRYNUM_",500"_$S(ENTRYNUM=500:$P(NODE,"500,500",2,99),1:$P(NODE,",500",2,99))
S @NODE500=REC500
Q
REC600 ;EP
S REC600=$G(@NODE)
I $P(REC600,U,2)="9002071.04PA" S $P(REC600,U,2)="9002071.06PA"
S NODE600=NEWNODE_",""D"","_ENTRYNUM_",600"_$S(ENTRYNUM=600:$P(NODE,"600,600",2,99),1:$P(NODE,",600",2,99))
S @NODE600=REC600
Q
REC650 ;EP
S REC650=$G(@NODE)
S NODE500=NEWNODE_",""D"","_ENTRYNUM_",500,1,0)"
I $D(@NODE500) D
.S COM500=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,0)"
.S COM500C=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,1,0)"
.S @COM500=U_"9002071.53^1^1"
.S @COM500C=REC650
S NODE600=NEWNODE_",""D"","_ENTRYNUM_",600,1,0)"
I $D(@NODE600) D
.S COM600=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,0)"
.S COM600C=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,1,0)"
.S @COM600=U_"9002071.63^1^1"
.S @COM600C=REC650
Q
;
REC700 ;EP
S REC700=$G(@NODE) ;CHANGE FROM 700 TO 800 FIELD GROUP
I $P(REC700,U,2)="9002071.06A" S $P(REC700,U,2)="9002071.08PA"
S NODE800=NEWNODE_",""D"","_ENTRYNUM_",800"_$S(ENTRYNUM=700:$P(NODE,"700,700",2,99),1:$P(NODE,",700",2,99))
S @NODE800=REC700
;OLD PIECE ONE IS A FREE TEXT ENTRY AND MUST BE CHANGED TO A POINTER
S OLDFREE=$P(@NODE800,U)
;FIND POSSIBLE INSURER USING OLD FREE TEXT ENTRY
S NEWPTR="",NAME=""
F S NAME=$O(^AUTNINS("B",NAME)) Q:NAME="" I NAME=OLDFREE S NEWPTR=NAME Q
I NEWPTR'="" S $P(@NODE800,U)=NEWPTR
Q
;
ERROR ;
S $ZT="ERRORH"
S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ERROR TRAP CALLED")=NOW
S XPDABORT=1
G ^%ET
;
ERRORCN ;
S $ZT="ERRORH"
D ERRREC
;
I NEWNODE[(QT_"D"_QT),($P(NEWNODE,CM,3)'="") S NEWNEW=$P(NEWNODE,CM,1,3)_")" I NEWNEW'="" K @NEWNEW
S REC=$P($P(NODE,"(",2),CM,1)
S NODE="^ACHSDEN("_(REC+1)_")"
G LOOP1
;
ERRORXR ;
;we get here if there is an error in creating the x-refs.
S $ZT="ERRORH"
D ERRREC
;
G LOOP2A
;
ERRREC ;
;record some info about this error before going on
S ERRNUM=+$O(^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,""),-1)+1
S ^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,ERRNUM,"$ZE")=$ZE
S ^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,ERRNUM,"NODE")=$G(NODE)
S ^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,ERRNUM,"NEWNODE")=$G(NEWNODE)
;
S NUMERR=NUMERR+1
I NUMERR>500!(NUMENTRY>1000&(NUMERR/NUMENTRY*100>5)) S STOP=1
Q
;
ERRORH ;
G ^XUSCLEAN
;
ACHSPRE ;IHS/ITSC/PMF - ENVIRONMENT CHECK-NAMESPACE CLEANUP ; [ 11/19/2001 8:18 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 SET $ZT="ERROR"
+4 SET U="^"
SET CM=","
+5 ;
+6 IF 'XPDENV
IF $DATA(^ACHSINST)
Begin DoDot:1
+7 MERGE ^ACHSINS1=^ACHSINST
+8 SET G=""
FOR
SET G=$ORDER(^ACHSINST(G))
IF G=""
QUIT
KILL ^ACHSINST(G)
+9 QUIT
End DoDot:1
+10 ;
+11 SET ^ACHSINST=""
SET G=$$NOJOURN^ZIBGCHAR("ACHSINIT")
+12 ;
+13 SET ACHSVERS="V"_$PIECE($TEXT(+2),";",3)
+14 SET $PIECE(LINE,"*",81)=""
+15 ;
+16 IF $DATA(^%ZOSF("MAXSIZ"))
SET X=250
XECUTE ^%ZOSF("MAXSIZ")
+17 ;
+18 ;GET THE CURRENT VERSION INSTALLED
+19 SET PACKNUM=$ORDER(^DIC(9.4,"B",$PIECE($TEXT(+2),";",4),""))
+20 IF PACKNUM=""
Begin DoDot:1
+21 WRITE !,$$C^XBFUNC("THERE IS SOMETHING WRONG WITH YOUR PACKAGE FILE!!")
+22 WRITE !,$$C^XBFUNC("THE PACKAGE IEN COULD NOT BE FOUND IN FILE #9.4!")
+23 SET XPDABORT=1
+24 DO SORRY
End DoDot:1
QUIT
+25 ;
+26 SET CVERSION=$GET(^DIC(9.4,PACKNUM,"VERSION"))
+27 IF CVERSION=""
Begin DoDot:1
+28 WRITE !,"THERE IS SOMETHING WRONG WITH YOUR PACKAGE FILE!!"
+29 WRITE !,"THE PACKAGE VERSION IN FILE #9.4 COULD NOT BE FOUND!"
+30 SET XPDABORT=1
+31 DO SORRY
End DoDot:1
QUIT
+32 ;
+33 WRITE !,"Checking, please wait..."
+34 DO INT^%SP
+35 IF %FTOTBLK/%TOTBLK*100<2
Begin DoDot:1
+36 WRITE !,"YOU HAVE LESS THAN 2% FREE SPACE. THIS IS NOT ENOUGH SPACE TO DO THE INSTALL."
+37 SET XPDABORT=1
+38 DO SORRY
+39 QUIT
End DoDot:1
QUIT
+40 ;
+41 WRITE !,"More checking, please wait..."
+42 SET TOTBYT=0
SET GLOB="^ACHSDEN"
+43 FOR
SET GLOB=$QUERY(@GLOB)
IF GLOB=""
QUIT
SET TOTBYT=TOTBYT+$LENGTH(GLOB)+$LENGTH(@GLOB)
+44 IF TOTBYT*2.5/1012>%FTOTBLK
Begin DoDot:1
+45 WRITE !,"YOU DO NOT HAVE ENOUGH FREE SPACE TO RUN THIS INSTALL."
+46 SET XPDABORT=1
+47 DO SORRY
+48 QUIT
End DoDot:1
QUIT
+49 ;
+50 ;if we are doing the initial check prior to installing, it's time
+51 ;to do the conversion
+52 IF 'XPDENV
DO CONV
+53 IF $GET(STOP)
Begin DoDot:1
+54 WRITE !,"THE TRIAL CONVERSION OF THE DENIAL DATA HAS FAILED"
+55 SET XPDABORT=1
DO SORRY
+56 QUIT
End DoDot:1
QUIT
+57 ;
+58 IF 'XPDENV
WRITE !!,"THE ENVIRONMENT CHECK WILL BE RUN WHEN THE INSTALL OPTION IS USED!"
QUIT
+59 ;
+60 ;END of pre install check
+61 ;
+62 SET XPDABORT=0
+63 ;
+64 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"DUZ VARIABLES NOT SET")=NOW
SET XPDABORT=1
DO SORRY
QUIT
+65 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"DUZ VARIABLES NOT SET")=NOW
SET XPDABORT=1
DO SORRY
QUIT
+66 SET INSTALER=$PIECE($GET(^VA(200,DUZ,0)),U)
+67 IF INSTALER=""
SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"UNKNOWN INSTALLER")=NOW
SET XPDABORT=1
DO SORRY
QUIT
+68 ;
ASKBACK ;
+1 SET DIR(0)="Y^^"
+2 SET DIR("A")="Has a SYSTEM BACKUP been successfully performed?"
+3 SET DIR("B")="NO"
+4 SET DIR("?")="Answer YES if backups were successfully performed."
+5 DO ^DIR
+6 IF $DATA(DUOUT)
WRITE !,"User initiated abort!",!,"Aborting installation!"
SET ERROR=1
SET XPDABORT=1
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"USER INITIATED ABORT!")=NOW
QUIT
+7 IF 'Y
WRITE !!,"Aborting installation!!"
SET ERROR=1
SET XPDABORT=1
IF Y=""
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"PROMPT TIMED OUT!")=NOW
QUIT
ASKCAPT ;
+1 SET DIR(0)="Y^^"
+2 SET DIR("A")="Has the 'Capture to file' option been turned on?"
+3 SET DIR("B")="NO"
+4 SET DIR("?")="Answer YES if the 'Capture to file' option is ON."
+5 DO ^DIR
+6 IF $DATA(DUOUT)
WRITE !,"User initiated abort!",!,"Aborting installation!!"
SET ERROR=1
SET XPDABORT=1
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"USER INITIATED ABORT!")=NOW
QUIT
+7 IF 'Y
WRITE !!,"Aborting installation!!"
SET ERROR=1
SET XPDABORT=1
IF Y=""
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"PROMPT TIMED OUT!")=NOW
QUIT
+8 ;
+9 ;
+10 DO HOME^%ZIS
DO DT^DICRW
+11 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+12 SET ^ACHSINST(ACHSVERS,"CHS INSTALL","STATUS","INSTALL BEGUN")=NOW
+13 SET ^ACHSINST(ACHSVERS,$ZN,"ENTERED")=NOW
+14 WRITE !,LINE
+15 WRITE !,$$C^XBFUNC("Hello, "_$PIECE(INSTALER,CM,2)_" "_$PIECE(INSTALER,CM)),!!,$$C^XBFUNC("Checking Environment for Installation of")
+16 WRITE !,$$C^XBFUNC("VERSION "_$PIECE($TEXT(+2),";",3)_" of "_$PIECE($TEXT(+2),";",4)_".")
+17 SET X=$GET(^DD("VERSION"))
+18 ;
+19 WRITE !!,"Need at least FileMan 21.....FileMan "_X_" Present"
+20 IF X<21
SET ^ACHSINST(ACHSVERS,"ERROR","ONLY HAVE FILEMAN "_X)=NOW
WRITE " Not Present!"
DO SORRY
QUIT
+21 SET X=$GET(^DIC(9.4,$ORDER(^DIC(9.4,"C","XU",0)),"VERSION"))
+22 WRITE !!,"Need at least Kernel 7.1.....Kernel "_X_" Present"
+23 IF X<7.1
SET ^ACHSINST(ACHSVERS,"ERROR","ONLY HAVE KERNEL "_X)=NOW
WRITE " Not Present!"
DO SORRY
QUIT
+24 WRITE !!,"Need HFS interface to Kernel (^%ZISH)....."
+25 SET ACHS=1
+26 SET ACHSRCHK="'$L($T(@X"_$SELECT($GET(^%ZOSF("OS"))["UNIX":"^%ZISH",1:"^ZISHMSMD")_"))"
+27 FOR X="OPEN","DEL","SEND","LIST","STATUS"
IF @ACHSRCHK
WRITE !,$JUSTIFY("",20)_X_"^%ZISH not Present"
SET ACHS=0
+28 IF 'ACHS
SET ^ACHSINST(ACHSVERS,"ERROR","NEED HFS INTERFACE ^%ZISH ROUTINES")=NOW
DO SORRY
QUIT
+29 ;
+30 SET X=$GET(^DIC(9.4,$ORDER(^DIC(9.4,"C","XB",0)),"VERSION"))
+31 WRITE !!,"Need XB/ZIB, v 3.0.....XB/ZIB "_X_" Present"
+32 IF X<3
SET ^ACHSINST(ACHSVERS,"ERROR","NEED XB/ZIB INSTALLED")=NOW
WRITE " Not Present!"
DO SORRY
QUIT
+33 ;
+34 SET X=$PIECE($TEXT(+2^AUTTVLK),";",3)
+35 SET X=$SELECT(X<89:"20"_X,1:"19"_X)
+36 SET X=$SELECT(X>1998:"Looks OK...",1:"")
+37 WRITE !!,"Need AUT IHS Standard Data Dictionaries, at least v 98.1 ...."_X
+38 IF '$LENGTH(X)
SET ^ACHSINST(ACHSVERS,"ERROR","NEED AUTT VERSION 98.1")=NOW
SET XPDABORT=1
WRITE " Not OK!"
DO SORRY
QUIT
+39 SET X=$PIECE($TEXT(+2^AUPNPAT),";",3)
+40 SET X=$SELECT(X<89:"20"_X,1:"19"_X)
+41 SET X=$SELECT(X>1999:"Looks OK...",1:"")
+42 WRITE !!,"Need AUPN, at least v 99.1 ...."_X
+43 IF '$LENGTH(X)
SET ^ACHSINST(ACHSVERS,"ERROR","NEED AUPN VERSION 99.1")=NOW
SET XPDABORT=1
WRITE " Not OK!"
DO SORRY
QUIT
+44 KILL ^TMP("ACHSPOST",$JOB)
+45 ;
+46 ;check conversion finished node
+47 SET RUNTIME=""
FOR
SET RUNTIME=$ORDER(^ACHS("V3.1","denial conversion","AMOCK",RUNTIME))
IF RUNTIME=""
QUIT
IF +$GET(^(RUNTIME))
QUIT
+48 ;
+49 ;10/31/01 pmf only check for the conversion if they are
+50 ;not already 3.1. replace one line
+51 ;I RUNTIME="" D Q
+52 IF RUNTIME=""
IF (CVERSION<3.1)
Begin DoDot:1
+53 WRITE !!,"CONVERSION OF DENIAL DATA NOT FOUND"
+54 SET ^ACHSINST(ACHSVERS,"ERROR","CONVERSION NOT COMPLETE"_X)=NOW
DO SORRY
+55 QUIT
End DoDot:1
QUIT
+56 ;
+57 WRITE !!,$$C^XBFUNC("ENVIRONMENT OK.")
+58 WRITE !,LINE
+59 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+60 SET ^ACHSINST(ACHSVERS,$ZN,"ENVIRONMENT CHECK OK")=NOW
+61 ;
+62 SET %H=$HOROLOG
DO YMD^%DTC
+63 DO DELDD
+64 ;
+65 WRITE !!,"CHS DICTIONARIES FROM PREVIOUS VERSION HAVE BEEN DELETED!"
+66 DO DELRTN
+67 SET ^ACHSINST(ACHSVERS,$ZN,"CHS NAMESPACE DELETIONS FINISHED")=NOW
+68 WRITE !!,"CHS ROUTINES FROM PREVIOUS VERSION HAVE BEEN DELETED!"
+69 WRITE !!,LINE
+70 KILL ^TMP("ACHSPOST")
+71 QUIT
+72 ;
SORRY ;
+1 KILL DIFQ
+2 WRITE *7,!!!,$$C^XBFUNC("Sorry....something is wrong with your environment")
+3 WRITE !,$$C^XBFUNC("Aborting Contract Health System install!")
+4 WRITE !,$$C^XBFUNC("Please print/capture this screen and notify")
+5 WRITE !,$$C^XBFUNC("the Support Team")
+6 WRITE !!,LINE
+7 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+8 SET XPDABORT=1
+9 ;
+10 SET ^ACHSINST(ACHSVERS,$ZN,"ENVIRONMENT CHECK FAILED")=NOW
+11 SET ^ACHSINST(ACHSVERS,$ZN,"ABORTED")=NOW
+12 ;
+13 SET Y=$$DIR^XBDIR("E","Press RETURN To Continue...","","","",1)
XECUTE ^%ZOSF("TRMRD")
+14 QUIT
+15 ;
DELRTN ;
+1 SET XPDIDTOT=384
SET XPDIDVT=10
SET XGCURATR=10
SET IOBM=10
+2 DO INIT^XPDID
+3 DO TITLE^XPDID("DELETING OLD CHS ROUTINES")
+4 DO SAY^XGF(10,10,"DELETING CHS ROUTINES.....")
+5 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+6 SET ^ACHSINST(ACHSVERS,"DELRTN^"_$ZN,"ENTERED")=NOW
+7 SET %RN="ACHRZZZ"
FOR COUNT=1:1
SET %RN=$ORDER(^(%RN))
IF %RN'[("ACH")&(%RN'[("AZZZE"))
QUIT
Begin DoDot:1
+8 SET $PIECE(FILLER," ",IOM-$LENGTH(%RN))=""
+9 DO SAY^XGF(12,10,"DELETING "_%RN_"....."_FILLER)
+10 XECUTE "ZR ZS @%RN"
+11 DO UPDATE^XPDID(COUNT)
End DoDot:1
+12 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+13 SET ^ACHSINST(ACHSVERS,"DELRTN^"_$ZN,"FINISHED")=NOW
+14 DO UPDATE^XPDID(0)
+15 DO EXIT^XPDID("FINISHED WITH CHS ROUTINE DELETE!")
+16 QUIT
+17 ;
DELDD ;
+1 SET XPDIDTOT=20
SET XPDIDVT=10
SET XGCURATR=10
SET IOBM=10
+2 DO INIT^XPDID
DO TITLE^XPDID("DELETING OLD CHS DATA DICTIONARIES")
+3 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+4 SET ^ACHSINST(ACHSVERS,"DELDD^"_$ZN,"ENTERED")=NOW
+5 FOR GLO="^DIC(","^DD("
Begin DoDot:1
+6 SET FILENUM=9002060.999999
+7 FOR COUNT=1:1
SET FILENUM=$ORDER(@(GLO_FILENUM_")"))
IF FILENUM>9002080.999999
QUIT
Begin DoDot:2
+8 SET GLOBAL=GLO_FILENUM_")"
+9 IF '$DATA(@GLOBAL)
DO SAY^XGF(12,10,GLOBAL_" NOT FOUND ON THIS SYSTEM!")
QUIT
+10 DO UPDATE^XPDID(COUNT)
+11 DO SAY^XGF(12,10,"KILLING GLOBAL "_GLOBAL_" ..........")
+12 KILL @GLOBAL
End DoDot:2
End DoDot:1
+13 SET TMP=$ORDER(^DIC("B","CHS DEFERRED SERVICES CATEGORY",""))
+14 IF TMP=9002068
KILL ^DIC("B","CHS DEFERRED SERVICES CATEGORY",9002068)
+15 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+16 SET ^ACHSINST(ACHSVERS,"DELDD^"_$ZN,"FINISHED")=NOW
+17 DO UPDATE^XPDID(0)
+18 DO EXIT^XPDID("FINISHED WITH CHS DATA DICTIONARY DELETE!")
+19 QUIT
+20 ;
CONV ; CONVERT CHS DENIAL DATA FROM OLD TO NEW STRUCTURE
+1 ;
+2 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
SET RUNTIME=Y
+3 IF '$GET(CVERSION)
SET ^ACHSINST(ACHSVERS,$ZN,"CONVERSION NOT DONE, FIRST TIME INSTALL")=NOW
QUIT
+4 ;
+5 IF +CVERSION>3
WRITE !!,"THE CURRENT VERSION OF CHS IS HIGER THAN 3.0",!,"CONVERSION PROCESS WILL BE BYPASSED!"
SET ^ACHSINST(ACHSVERS,$ZN,"CONVERSION BYPASSED DUE TO HIGH VERSION")=NOW
QUIT
+6 ;
+7 SET LINE=$GET(LINE)
+8 WRITE !!,LINE,!!,"Starting trial conversion, please be patient"
+9 SET ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"ENTERED")=NOW
+10 ;
+11 SET (NUMENTRY,NUMERR,STOP)=0
SET QT=""""
+12 ;
+13 ;S NODE=$G(^ACHSINST(VERS,"CONVERSION",MOCK,"LAST NODE"))
+14 SET NODE=""
+15 IF NODE=""
SET NODE="^ACHSDEN"
+16 ;
+17 ;stop journaling on the globals, if they exist
+18 SET G=$$NOJOURN^ZIBGCHAR("ACHSDEN")
+19 IF $DATA(^ACHSDENY)
SET G=$$NOJOURN^ZIBGCHAR("ACHSDENY")
+20 IF $DATA(^ACHSDENZ)
SET G=$$NOJOURN^ZIBGCHAR("ACHSDENZ")
+21 ;
+22 ;kill off globals one and two, just in case they exist
+23 SET G=""
FOR
SET G=$ORDER(^ACHSDENY(G))
IF G=""
QUIT
KILL ^(G)
+24 SET G=""
FOR
SET G=$ORDER(^ACHSDENZ(G))
IF G=""
QUIT
KILL ^(G)
+25 ;
+26 ;establish top node of globals one and two
+27 SET ^ACHSDENY=""
SET ^ACHSDENZ=""
+28 ;stop journaling on the globals again, now that we know they exist
+29 SET G=$$NOJOURN^ZIBGCHAR("ACHSDEN")
SET G=$$NOJOURN^ZIBGCHAR("ACHSDENY")
SET G=$$NOJOURN^ZIBGCHAR("ACHSDENZ")
+30 ;
+31 MERGE ^ACHSDENZ=^ACHSDEN
+32 SET NEWNODE="^ACHSDENY("
+33 ;
+34 DO LOOP1
+35 IF 'STOP
DO SET1
+36 IF 'STOP
DO LOOP2
+37 ;
+38 SET %H=$HOROLOG
DO YX^%DTC
+39 SET ^ACHS("V3.1","denial conversion","AMOCK",RUNTIME)='STOP_U_Y
+40 ;
+41 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+42 SET ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"FINISHED")=NOW
+43 ;
+44 QUIT
+45 ;
LOOP1 ;
+1 SET $ZT="ERRORCN"
+2 ;
+3 FOR
SET NODE=$QUERY(@NODE)
IF NODE=""!(STOP)
QUIT
Begin DoDot:1
+4 ;
+5 ;SKIP X-REFS WE DO NOT NEED TO CONVERT THESE.
+6 SET FIRSTSUB=$PIECE($PIECE(NODE,CM),"(",2)
+7 IF FIRSTSUB?1""""1A.E1""""
QUIT
+8 ;
+9 ;check for alpha subscripts, indicating a cross reference
+10 ;do not process these
+11 SET FOUND=0
FOR XXI=3:1:99
SET XXS=$PIECE($PIECE(NODE,"(",2),CM,XXI)
IF XXS=""
QUIT
IF XXS?1""""1A.E1""""
SET FOUND=1
QUIT
+12 KILL XXI,XXS
IF FOUND
QUIT
+13 KILL FOUND
+14 ;CHECK FOR NEW DATA STRUCTURE MIXED WITH OLD, copy new data as is
+15 IF NODE[("""D""")
DO ASIS
QUIT
+16 IF NODE[(",0)")
IF $LENGTH(NODE,CM)=2
DO REC0
QUIT
+17 IF NODE[(",10)")
DO REC10
QUIT
+18 IF NODE[(",100)")
DO REC100
QUIT
+19 IF NODE[(",200,")
DO REC200
QUIT
+20 IF NODE[(",210,")
DO REC210
QUIT
+21 IF NODE[(",290)")
DO REC290
QUIT
+22 IF NODE[(",300,")
DO REC300
QUIT
+23 IF NODE[(",400)")
DO REC400
QUIT
+24 IF NODE[(",500,")
DO REC500
QUIT
+25 IF NODE[(",600,")
DO REC600
QUIT
+26 IF NODE[(",650)")
DO REC650
QUIT
+27 IF NODE[(",700,")
DO REC700
QUIT
+28 QUIT
End DoDot:1
+29 ;
+30 ;that ends the main loop of the conversion
+31 QUIT
+32 ;
SET1 ;
+1 SET NEWNODE="^ACHSDENY(0)"
+2 SET @NEWNODE="CHS DENIAL DATA^9002071I"_U_$SELECT($GET(ISSUEFAC)="":0,1:ISSUEFAC)_U_$SELECT($GET(NUMENTRY)="":0,1:NUMENTRY)
+3 ;
+4 ;DO COUNTS OF FACILITIES AND ITEMS WITHIN FACILITY
+5 SET FAC=0
FOR CNT=1:1
SET FAC=$ORDER(^ACHSDENY(FAC))
IF +FAC=0
QUIT
Begin DoDot:1
+6 SET ITEM=0
FOR CNT2=1:1
SET ITEM=$ORDER(^ACHSDENY(FAC,"D",ITEM))
IF +ITEM=0
QUIT
Begin DoDot:2
+7 SET NEWNODE="^ACHSDENY("_FAC_CM_QT_"D"_QT_CM_"0)"
+8 SET @NEWNODE=U_"9002071.01A"_U_ITEM_U_CNT2
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 ;
+12 QUIT
+13 ;
LOOP2 ;
+1 ;the data is now converted and sitting in ^ACHSDENY.
+2 ;here we set up the cross references for it.
+3 WRITE !!!,"Re-indexing new Denial file..."
+4 ;
+5 SET FAC=0
FOR
SET FAC=$ORDER(^ACHSDENY(FAC))
IF '+FAC
QUIT
IF STOP
QUIT
SET DEN=0
DO LOOP2A
+6 QUIT
+7 ;
LOOP2A ;
+1 ;note start of new error trap
+2 SET $ZT="ERRORXR"
+3 ;
+4 FOR
SET DEN=$ORDER(^ACHSDENY(FAC,"D",DEN))
IF '+DEN
QUIT
IF STOP
QUIT
Begin DoDot:1
+5 SET DAT=$GET(^ACHSDENY(FAC,"D",DEN,0))
+6 IF DAT=""
QUIT
+7 SET NODE="^ACHSDENY("_FAC_CM_QT_"D"_QT_CM_DEN
+8 SET DENIAL=$PIECE(DAT,U,1)
SET AISSUE=$PIECE(DAT,U,2)
SET ES=$PIECE(DAT,U,4)
+9 IF AISSUE'=""
SET ^ACHSDENY(FAC,"D","AISSUE",AISSUE,DEN)=""
+10 IF DENIAL'=""
SET ^ACHSDENY(FAC,"D","B",DENIAL,DEN)=""
+11 IF ES'=""
SET ^ACHSDENY(FAC,"D","ES",ES,DEN)=""
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
+15 WRITE !,"Denial Updates Completed at ",$$FMTE^XLFDT(%)
+16 SET ^ACHSINST(ACHSVERS,"REINDEX^"_$ZN,"FINISHED")=NOW
+17 ;
+18 QUIT
+19 ;
ASIS ;
+1 ;COPY AS IS THIS IS THE NEW DATA STRUCTURE
+2 SET RECORD=$GET(@NODE)
+3 SET SUB1=$PIECE(NODE,"(",2,299)
+4 SET ASISNODE="^ACHSDEN("_SUB1
+5 SET @ASISNODE=RECORD
+6 ;
+7 QUIT
+8 ;
REC0 ;
+1 ;GET THE ZERO NODE AND REARRANGE THE PIECES
+2 SET NUMENTRY=NUMENTRY+1
+3 IF NUMENTRY#100=0
WRITE !,?18,NUMENTRY," denials examined so far"
+4 SET REC0=$GET(@NODE)
+5 SET DENIAL=$PIECE(REC0,U)
+6 SET ISSUEDT=$PIECE(REC0,U,2)
+7 SET SERVDT=$PIECE(REC0,U,3)
+8 SET ISREG=$PIECE(REC0,U,4)
+9 SET PAT=$PIECE(REC0,U,5)
+10 SET ISSUEBY=$PIECE(REC0,U,6)
+11 SET REQDT=$PIECE(REC0,U,7)
+12 SET ISSUEFAC=$PIECE(REC0,U,8)
+13 ;
+14 IF ISSUEFAC=""
SET ISSUEFAC=$ORDER(^ACHSF("B",0))
+15 ;
+16 SET ENTRYNUM=$PIECE($PIECE(NODE,","),"(",2)
+17 ;
+18 ;CHECK FOR EXISTING ENTRIES HERE (THIS SHOULD ONLY HAPPEN IN SITES WITH
+19 ;THE OLD STRUCTURE MIXED WITH THE NEW)
+20 IF $DATA(^ACHSDEN(ISSUEFAC,"D",ENTRYNUM))
WRITE !,"ENTRY "_ENTRYNUM_" ALREADY EXISTS FOR THIS "_ISSUEFAC_"!"
SET ENTRYNUM=$ORDER(^ACHSDEN(ISSUEFAC,"D","A"),-1)+1
+21 ;
+22 SET NEWNODE="^ACHSDENY("_ISSUEFAC
+23 ;
+24 SET @(NEWNODE_",0)")=ISSUEFAC
+25 SET NODE0=NEWNODE_",""D"","_ENTRYNUM_",0)"
+26 SET @NODE0=DENIAL_U_ISSUEDT_U_ISSUEBY_U_SERVDT_U_REQDT_U_ISREG_U_PAT
+27 ;
+28 QUIT
REC10 ;EP
+1 ;NO CHANGE IN PIECES
SET REC10=$GET(@NODE)
+2 SET NODE10=NEWNODE_",""D"","_ENTRYNUM_",10)"
+3 SET @NODE10=REC10
+4 QUIT
REC100 ;EP
+1 ;NO CHANGE IN PIECES
SET REC100=$GET(@NODE)
+2 SET NODE100=NEWNODE_",""D"","_ENTRYNUM_",100)"
+3 SET @NODE100=REC100
+4 QUIT
REC200 ;EP
+1 SET REC200=$GET(@NODE)
+2 IF $PIECE(REC200,U,2)="9002071.01PA"
SET $PIECE(REC200,U,2)="9002071.02PA"
+3 SET NODE200=NEWNODE_",""D"","_ENTRYNUM_",200"_$SELECT(ENTRYNUM=200:$PIECE(NODE,"200,200",2,99),1:$PIECE(NODE,",200",2,99))
+4 SET @NODE200=REC200
+5 QUIT
REC210 ;EP
+1 ;NO CHANGE IN PIECES
SET REC210=$GET(@NODE)
+2 IF $PIECE(REC210,U,2)="9002071.05A"
SET $PIECE(REC210,U,2)="9002071.03A"
+3 SET NODE210=NEWNODE_",""D"","_ENTRYNUM_",210"_$SELECT(ENTRYNUM=210:$PIECE(NODE,"210,210",2,99),1:$PIECE(NODE,",210",2,99))
+4 SET @NODE210=REC210
+5 QUIT
REC290 ;EP
+1 ;CHANGE TO NODE 250 SAME PIECE
SET REC290=$GET(@NODE)
+2 SET NODE250=NEWNODE_",""D"","_ENTRYNUM_",250)"
+3 SET @NODE250=REC290
+4 QUIT
REC300 ;EP
+1 ;NO CHANGE IN PIECES
SET REC300=$GET(@NODE)
+2 IF $PIECE(REC300,U,2)="9002071.02PA"
SET $PIECE(REC300,U,2)="9002071.04PA"
+3 SET NODE300=NEWNODE_",""D"","_ENTRYNUM_",300"_$SELECT(ENTRYNUM=300:$PIECE(NODE,"300,300",2,99),1:$PIECE(NODE,",300",2,99))
+4 SET @NODE300=REC300
+5 QUIT
REC400 ;EP
+1 ;PIECES CHANGE
SET REC400=$GET(@NODE)
+2 SET DEFSER=$PIECE(REC400,U)
+3 SET PRICAT=$PIECE(REC400,U,4)
+4 SET MPRICAT=""
+5 IF PRICAT'=""
SET MPRICAT=$ORDER(^ACHSMPRI("B",PRICAT,MPRICAT))
+6 SET APPEAL=$PIECE(REC400,U,5)
+7 SET NREC400=DEFSER_U_MPRICAT_U_APPEAL
+8 SET NODE400=NEWNODE_",""D"","_ENTRYNUM_",400)"
+9 SET @NODE400=NREC400
+10 QUIT
REC500 ;EP
+1 SET REC500=$GET(@NODE)
+2 IF $PIECE(REC500,U,2)="9002071.03PA"
SET $PIECE(REC500,U,2)="9002071.05PA"
+3 SET NODE500=NEWNODE_",""D"","_ENTRYNUM_",500"_$SELECT(ENTRYNUM=500:$PIECE(NODE,"500,500",2,99),1:$PIECE(NODE,",500",2,99))
+4 SET @NODE500=REC500
+5 QUIT
REC600 ;EP
+1 SET REC600=$GET(@NODE)
+2 IF $PIECE(REC600,U,2)="9002071.04PA"
SET $PIECE(REC600,U,2)="9002071.06PA"
+3 SET NODE600=NEWNODE_",""D"","_ENTRYNUM_",600"_$SELECT(ENTRYNUM=600:$PIECE(NODE,"600,600",2,99),1:$PIECE(NODE,",600",2,99))
+4 SET @NODE600=REC600
+5 QUIT
REC650 ;EP
+1 SET REC650=$GET(@NODE)
+2 SET NODE500=NEWNODE_",""D"","_ENTRYNUM_",500,1,0)"
+3 IF $DATA(@NODE500)
Begin DoDot:1
+4 SET COM500=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,0)"
+5 SET COM500C=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,1,0)"
+6 SET @COM500=U_"9002071.53^1^1"
+7 SET @COM500C=REC650
End DoDot:1
+8 SET NODE600=NEWNODE_",""D"","_ENTRYNUM_",600,1,0)"
+9 IF $DATA(@NODE600)
Begin DoDot:1
+10 SET COM600=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,0)"
+11 SET COM600C=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,1,0)"
+12 SET @COM600=U_"9002071.63^1^1"
+13 SET @COM600C=REC650
End DoDot:1
+14 QUIT
+15 ;
REC700 ;EP
+1 ;CHANGE FROM 700 TO 800 FIELD GROUP
SET REC700=$GET(@NODE)
+2 IF $PIECE(REC700,U,2)="9002071.06A"
SET $PIECE(REC700,U,2)="9002071.08PA"
+3 SET NODE800=NEWNODE_",""D"","_ENTRYNUM_",800"_$SELECT(ENTRYNUM=700:$PIECE(NODE,"700,700",2,99),1:$PIECE(NODE,",700",2,99))
+4 SET @NODE800=REC700
+5 ;OLD PIECE ONE IS A FREE TEXT ENTRY AND MUST BE CHANGED TO A POINTER
+6 SET OLDFREE=$PIECE(@NODE800,U)
+7 ;FIND POSSIBLE INSURER USING OLD FREE TEXT ENTRY
+8 SET NEWPTR=""
SET NAME=""
+9 FOR
SET NAME=$ORDER(^AUTNINS("B",NAME))
IF NAME=""
QUIT
IF NAME=OLDFREE
SET NEWPTR=NAME
QUIT
+10 IF NEWPTR'=""
SET $PIECE(@NODE800,U)=NEWPTR
+11 QUIT
+12 ;
ERROR ;
+1 SET $ZT="ERRORH"
+2 SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ERROR TRAP CALLED")=NOW
+3 SET XPDABORT=1
+4 GOTO ^%ET
+5 ;
ERRORCN ;
+1 SET $ZT="ERRORH"
+2 DO ERRREC
+3 ;
+4 IF NEWNODE[(QT_"D"_QT)
IF ($PIECE(NEWNODE,CM,3)'="")
SET NEWNEW=$PIECE(NEWNODE,CM,1,3)_")"
IF NEWNEW'=""
KILL @NEWNEW
+5 SET REC=$PIECE($PIECE(NODE,"(",2),CM,1)
+6 SET NODE="^ACHSDEN("_(REC+1)_")"
+7 GOTO LOOP1
+8 ;
ERRORXR ;
+1 ;we get here if there is an error in creating the x-refs.
+2 SET $ZT="ERRORH"
+3 DO ERRREC
+4 ;
+5 GOTO LOOP2A
+6 ;
ERRREC ;
+1 ;record some info about this error before going on
+2 SET ERRNUM=+$ORDER(^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,""),-1)+1
+3 SET ^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,ERRNUM,"$ZE")=$ZE
+4 SET ^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,ERRNUM,"NODE")=$GET(NODE)
+5 SET ^ACHSINST(ACHSVERS,"denial conversion","ERRORS",RUNTIME,ERRNUM,"NEWNODE")=$GET(NEWNODE)
+6 ;
+7 SET NUMERR=NUMERR+1
+8 IF NUMERR>500!(NUMENTRY>1000&(NUMERR/NUMENTRY*100>5))
SET STOP=1
+9 QUIT
+10 ;
ERRORH ;
+1 GOTO ^XUSCLEAN
+2 ;
